From b827f58245d2b9b2b7b03f2a2e5946f4e64fcf9e Mon Sep 17 00:00:00 2001 From: Kate Hedstrom Date: Mon, 2 Dec 2019 14:56:16 -0900 Subject: [PATCH 001/316] Allows for rotation of dumbbell test. --- src/user/dumbbell_initialization.F90 | 85 +++++++++++++++++++-------- src/user/dumbbell_surface_forcing.F90 | 14 ++++- 2 files changed, 74 insertions(+), 25 deletions(-) diff --git a/src/user/dumbbell_initialization.F90 b/src/user/dumbbell_initialization.F90 index b16b3a341c..3e07ac839e 100644 --- a/src/user/dumbbell_initialization.F90 +++ b/src/user/dumbbell_initialization.F90 @@ -49,6 +49,7 @@ subroutine dumbbell_initialize_topography( D, G, param_file, max_depth ) ! Local variables integer :: i, j real :: x, y, delta, dblen, dbfrac + logical :: dbrotate call get_param(param_file, mdl,"DUMBBELL_LEN",dblen, & 'Lateral Length scale for dumbbell.',& @@ -56,20 +57,35 @@ subroutine dumbbell_initialize_topography( D, G, param_file, max_depth ) call get_param(param_file, mdl,"DUMBBELL_FRACTION",dbfrac, & 'Meridional fraction for narrow part of dumbbell.',& units='nondim', default=0.5, do_not_log=.false.) + call get_param(param_file, mdl, "DUMBBELL_ROTATION", dbrotate, & + 'Logical for rotation of dumbbell domain.',& + units='nondim', default=.false., do_not_log=.false.) if (G%x_axis_units == 'm') then dblen=dblen*1.e3 endif - do j=G%jsc,G%jec ; do i=G%isc,G%iec - ! Compute normalized zonal coordinates (x,y=0 at center of domain) - x = ( G%geoLonT(i,j) ) / dblen - y = ( G%geoLatT(i,j) ) / G%len_lat - D(i,j) = G%max_depth - if ((x>=-0.25 .and. x<=0.25) .and. (y <= -0.5*dbfrac .or. y >= 0.5*dbfrac)) then - D(i,j) = 0.0 - endif - enddo ; enddo + if (dbrotate) then + do j=G%jsc,G%jec ; do i=G%isc,G%iec + ! Compute normalized zonal coordinates (x,y=0 at center of domain) + x = ( G%geoLonT(i,j) ) / G%len_lon + y = ( G%geoLatT(i,j) ) / dblen + D(i,j) = G%max_depth + if ((y>=-0.25 .and. y<=0.25) .and. (x <= -0.5*dbfrac .or. x >= 0.5*dbfrac)) then + D(i,j) = 0.0 + endif + enddo ; enddo + else + do j=G%jsc,G%jec ; do i=G%isc,G%iec + ! Compute normalized zonal coordinates (x,y=0 at center of domain) + x = ( G%geoLonT(i,j) ) / dblen + y = ( G%geoLatT(i,j) ) / G%len_lat + D(i,j) = G%max_depth + if ((x>=-0.25 .and. x<=0.25) .and. (y <= -0.5*dbfrac .or. y >= 0.5*dbfrac)) then + D(i,j) = 0.0 + endif + enddo ; enddo + endif end subroutine dumbbell_initialize_topography @@ -209,6 +225,7 @@ subroutine dumbbell_initialize_temperature_salinity ( T, S, h, G, GV, param_file real :: x, y, dblen real :: T_ref, T_Light, T_Dense, S_ref, S_Light, S_Dense, a1, frac_dense, k_frac, res_rat logical :: just_read ! If true, just read parameters but set nothing. + logical :: dbrotate ! If true, rotate the domain. character(len=20) :: verticalCoordinate, density_profile is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke @@ -230,6 +247,9 @@ subroutine dumbbell_initialize_temperature_salinity ( T, S, h, G, GV, param_file call get_param(param_file, mdl,"DUMBBELL_LEN",dblen, & 'Lateral Length scale for dumbbell ',& units='k', default=600., do_not_log=just_read) + call get_param(param_file, mdl, "DUMBBELL_ROTATION", dbrotate, & + 'Logical for rotation of dumbbell domain.',& + units='nondim', default=.false., do_not_log=just_read) if (G%x_axis_units == 'm') then dblen=dblen*1.e3 @@ -238,7 +258,12 @@ subroutine dumbbell_initialize_temperature_salinity ( T, S, h, G, GV, param_file do j=G%jsc,G%jec do i=G%isc,G%iec ! Compute normalized zonal coordinates (x,y=0 at center of domain) - x = ( G%geoLonT(i,j) ) / dblen + if (dbrotate) then + ! This is really y in the rotated case + x = ( G%geoLatT(i,j) ) / dblen + else + x = ( G%geoLonT(i,j) ) / dblen + endif do k=1,nz T(i,j,k)=T_surf enddo @@ -278,9 +303,13 @@ subroutine dumbbell_initialize_sponges(G, GV, US, tv, param_file, use_ALE, CSp, integer :: i, j, k, nz real :: x, zi, zmid, dist, min_thickness, dblen real :: mld, S_ref, S_range, S_dense, T_ref, sill_height + logical :: dbrotate ! If true, rotate the domain. call get_param(param_file, mdl,"DUMBBELL_LEN",dblen, & 'Lateral Length scale for dumbbell ',& units='k', default=600., do_not_log=.true.) + call get_param(param_file, mdl, "DUMBBELL_ROTATION", dbrotate, & + 'Logical for rotation of dumbbell domain.',& + units='nondim', default=.false., do_not_log=.true.) if (G%x_axis_units == 'm') then dblen=dblen*1.e3 @@ -307,7 +336,12 @@ subroutine dumbbell_initialize_sponges(G, GV, US, tv, param_file, use_ALE, CSp, do i = G%isc,G%iec if (G%mask2dT(i,j) > 0.) then ! nondimensional x position - x = (G%geoLonT(i,j) ) / dblen + if (dbrotate) then + ! This is really y in the rotated case + x = ( G%geoLatT(i,j) ) / dblen + else + x = ( G%geoLonT(i,j) ) / dblen + endif if (x > 0.25 .or. x < -0.25) then ! scale restoring by depth into sponge Idamp(i,j) = 1. / sponge_time_scale @@ -339,18 +373,23 @@ subroutine dumbbell_initialize_sponges(G, GV, US, tv, param_file, use_ALE, CSp, do j=G%jsc,G%jec ; do i=G%isc,G%iec ! Compute normalized zonal coordinates (x,y=0 at center of domain) - x = ( G%geoLonT(i,j) ) / dblen - if (x>=0.25 ) then - do k=1,nz - S(i,j,k)=S_ref + 0.5*S_range - enddo - endif - if (x<=-0.25 ) then - do k=1,nz - S(i,j,k)=S_ref - 0.5*S_range - enddo - endif - enddo ; enddo + if (dbrotate) then + ! This is really y in the rotated case + x = ( G%geoLatT(i,j) ) / dblen + else + x = ( G%geoLonT(i,j) ) / dblen + endif + if (x>=0.25 ) then + do k=1,nz + S(i,j,k)=S_ref + 0.5*S_range + enddo + endif + if (x<=-0.25 ) then + do k=1,nz + S(i,j,k)=S_ref - 0.5*S_range + enddo + endif + enddo ; enddo endif if (associated(tv%S)) call set_up_ALE_sponge_field(S, G, tv%S, ACSp) diff --git a/src/user/dumbbell_surface_forcing.F90 b/src/user/dumbbell_surface_forcing.F90 index d6d6dea11a..2d19cce6dd 100644 --- a/src/user/dumbbell_surface_forcing.F90 +++ b/src/user/dumbbell_surface_forcing.F90 @@ -189,6 +189,7 @@ subroutine dumbbell_surface_forcing_init(Time, G, US, param_file, diag, CS) real :: S_surf, S_range real :: x, y integer :: i, j + logical :: dbrotate ! If true, rotate the domain. #include "version_variable.h" character(len=40) :: mdl = "dumbbell_surface_forcing" ! This module's name. @@ -224,6 +225,9 @@ subroutine dumbbell_surface_forcing_init(Time, G, US, param_file, diag, CS) call get_param(param_file, mdl, "DUMBBELL_SLP_PERIOD", CS%slp_period, & "Periodicity of SLP forcing in reservoirs.", & units="days", default = 1.0) + call get_param(param_file, mdl, "DUMBBELL_ROTATION", dbrotate, & + 'Logical for rotation of dumbbell domain.',& + units='nondim', default=.false., do_not_log=.true.) call get_param(param_file, mdl,"INITIAL_SSS", S_surf, & "Initial surface salinity", units="1e-3", default=34.0, do_not_log=.true.) call get_param(param_file, mdl,"INITIAL_S_RANGE", S_range, & @@ -250,8 +254,14 @@ subroutine dumbbell_surface_forcing_init(Time, G, US, param_file, diag, CS) do j=G%jsc,G%jec do i=G%isc,G%iec ! Compute normalized zonal coordinates (x,y=0 at center of domain) - x = ( G%geoLonT(i,j) - G%west_lon ) / G%len_lon - 0.5 - y = ( G%geoLatT(i,j) - G%south_lat ) / G%len_lat - 0.5 +! x = ( G%geoLonT(i,j) - G%west_lon ) / G%len_lon - 0.5 +! y = ( G%geoLatT(i,j) - G%south_lat ) / G%len_lat - 0.5 + if (dbrotate) then + ! This is really y in the rotated case + x = ( G%geoLatT(i,j) - G%south_lat ) / G%len_lat - 0.5 + else + x = ( G%geoLonT(i,j) - G%west_lon ) / G%len_lon - 0.5 + endif CS%forcing_mask(i,j)=0 CS%S_restore(i,j) = S_surf if ((x>0.25)) then From bd38913d6b5b25ae929aeec01bd2b5fd67500b03 Mon Sep 17 00:00:00 2001 From: Kate Hedstrom Date: Tue, 10 Dec 2019 21:37:31 -0900 Subject: [PATCH 002/316] *Fixed two little OBC bugs. - has the potential to change answers, depending on the options used. --- src/core/MOM_continuity_PPM.F90 | 2 +- src/core/MOM_open_boundary.F90 | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/src/core/MOM_continuity_PPM.F90 b/src/core/MOM_continuity_PPM.F90 index 96fa98cbf3..b361cd7a82 100644 --- a/src/core/MOM_continuity_PPM.F90 +++ b/src/core/MOM_continuity_PPM.F90 @@ -1331,7 +1331,7 @@ subroutine merid_flux_layer(v, h, h_L, h_R, vh, dvhdv, visc_rem, dt, G, US, J, & local_open_BC = .false. if (present(OBC)) then ; if (associated(OBC)) then - local_open_BC = OBC%open_u_BCs_exist_globally + local_open_BC = OBC%open_v_BCs_exist_globally endif ; endif do i=ish,ieh ; if (do_I(i)) then diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index f35748dd4a..d964c65145 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -2774,7 +2774,7 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, US, dt) enddo ; enddo endif if (segment%nudged_grad) then - do k=1,nz ; do J=segment%HI%JsdB,segment%HI%JedB + do k=1,nz ; do I=segment%HI%IsdB,segment%HI%IedB ! dhdt gets set to 0 on inflow in oblique case if (ry_tang_rad(I,J,k) <= 0.0) then tau = segment%Velocity_nudging_timescale_in From 722c1f5fc55812c386097bff7c8a616fb4dbb031 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 13 Dec 2019 18:15:15 -0500 Subject: [PATCH 003/316] +(*)Specify sponge damping rates in [T-1] Specify sponge damping rates in [T-1], instead of [s-1], for code simplification and expanded dimensional consistency testing. This required the addition of a unit_scale_type argument to two initialization routines, and an obvious bug was fixed in BFB_initialize_sponges_southonly, which is not actively tested. All answers are bitwise identical in the MOM6-examples test cases, but some interfaces changed and there could be answer changes in one user-provided example. --- .../MOM_state_initialization.F90 | 8 ++-- .../vertical/MOM_ALE_sponge.F90 | 24 +++++----- src/parameterizations/vertical/MOM_sponge.F90 | 8 ++-- src/user/BFB_initialization.F90 | 25 +++++----- src/user/DOME2d_initialization.F90 | 13 ++--- src/user/DOME_initialization.F90 | 18 +++---- src/user/ISOMIP_initialization.F90 | 48 +++++++++---------- src/user/Phillips_initialization.F90 | 12 ++--- src/user/RGC_initialization.F90 | 38 ++++++--------- src/user/dense_water_initialization.F90 | 19 ++++---- src/user/dumbbell_initialization.F90 | 7 +-- 11 files changed, 107 insertions(+), 113 deletions(-) diff --git a/src/initialization/MOM_state_initialization.F90 b/src/initialization/MOM_state_initialization.F90 index ff08912191..bc0ffb959e 100644 --- a/src/initialization/MOM_state_initialization.F90 +++ b/src/initialization/MOM_state_initialization.F90 @@ -540,7 +540,7 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, US, PF, dirs, & " \t USER - call a user modified routine.", default="file") select case (trim(config)) case ("DOME"); call DOME_initialize_sponges(G, GV, US, tv, PF, sponge_CSp) - case ("DOME2D"); call DOME2d_initialize_sponges(G, GV, tv, PF, useALE, & + case ("DOME2D"); call DOME2d_initialize_sponges(G, GV, US, tv, PF, useALE, & sponge_CSp, ALE_sponge_CSp) case ("ISOMIP"); call ISOMIP_initialize_sponges(G, GV, US, tv, PF, useALE, & sponge_CSp, ALE_sponge_CSp) @@ -552,7 +552,7 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, US, PF, dirs, & case ("DUMBBELL"); call dumbbell_initialize_sponges(G, GV, US, tv, PF, useALE, & sponge_CSp, ALE_sponge_CSp) case ("phillips"); call Phillips_initialize_sponges(G, GV, US, tv, PF, sponge_CSp, h) - case ("dense"); call dense_water_initialize_sponges(G, GV, tv, PF, useALE, & + case ("dense"); call dense_water_initialize_sponges(G, GV, US, tv, PF, useALE, & sponge_CSp, ALE_sponge_CSp) case ("file"); call initialize_sponges_file(G, GV, US, use_temperature, tv, PF, & sponge_CSp, ALE_sponge_CSp, Time) @@ -1713,7 +1713,7 @@ subroutine initialize_sponges_file(G, GV, US, use_temperature, tv, param_file, C real, dimension (SZI_(G),SZJ_(G)) :: & tmp_2d ! A temporary array for tracers. - real :: Idamp(SZI_(G),SZJ_(G)) ! The inverse damping rate [s-1]. + real :: Idamp(SZI_(G),SZJ_(G)) ! The inverse damping rate [T-1 ~> s-1]. real :: pres(SZI_(G)) ! An array of the reference pressure [Pa]. integer :: i, j, k, is, ie, js, je, nz @@ -1775,7 +1775,7 @@ subroutine initialize_sponges_file(G, GV, US, use_temperature, tv, param_file, C if (new_sponges .and. .not. use_ALE) & call MOM_error(FATAL, " initialize_sponges: Newer sponges are currently unavailable in layered mode ") - call MOM_read_data(filename, "Idamp", Idamp(:,:), G%Domain) + call MOM_read_data(filename, "Idamp", Idamp(:,:), G%Domain, scale=US%T_to_s) ! Now register all of the fields which are damped in the sponge. ! By default, momentum is advected vertically within the sponge, but diff --git a/src/parameterizations/vertical/MOM_ALE_sponge.F90 b/src/parameterizations/vertical/MOM_ALE_sponge.F90 index bdf422bec8..a9e8bb0746 100644 --- a/src/parameterizations/vertical/MOM_ALE_sponge.F90 +++ b/src/parameterizations/vertical/MOM_ALE_sponge.F90 @@ -141,7 +141,7 @@ subroutine initialize_ALE_sponge_fixed(Iresttime, G, param_file, CS, data_h, nz_ type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. integer, intent(in) :: nz_data !< The total number of sponge input layers. - real, dimension(SZI_(G),SZJ_(G)), intent(in) :: Iresttime !< The inverse of the restoring time [s-1]. + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: Iresttime !< The inverse of the restoring time [T-1 ~> s-1]. type(param_file_type), intent(in) :: param_file !< A structure indicating the open file !! to parse for model parameter values. type(ALE_sponge_CS), pointer :: CS !< A pointer that is set to point to the control @@ -156,8 +156,8 @@ subroutine initialize_ALE_sponge_fixed(Iresttime, G, param_file, CS, data_h, nz_ logical :: use_sponge real, allocatable, dimension(:,:,:) :: data_hu !< thickness at u points [H ~> m or kg m-2] real, allocatable, dimension(:,:,:) :: data_hv !< thickness at v points [H ~> m or kg m-2] - real, allocatable, dimension(:,:) :: Iresttime_u !< inverse of the restoring time at u points [s-1] - real, allocatable, dimension(:,:) :: Iresttime_v !< inverse of the restoring time at v points [s-1] + real, allocatable, dimension(:,:) :: Iresttime_u !< inverse of the restoring time at u points [T-1 ~> s-1] + real, allocatable, dimension(:,:) :: Iresttime_v !< inverse of the restoring time at v points [T-1 ~> s-1] logical :: bndExtrapolation = .true. ! If true, extrapolate boundaries integer :: i, j, k, col, total_sponge_cols, total_sponge_cols_u, total_sponge_cols_v character(len=10) :: remapScheme @@ -216,7 +216,7 @@ subroutine initialize_ALE_sponge_fixed(Iresttime, G, param_file, CS, data_h, nz_ do j=G%jsc,G%jec ; do i=G%isc,G%iec if ((Iresttime(i,j)>0.0) .and. (G%mask2dT(i,j)>0)) then CS%col_i(col) = i ; CS%col_j(col) = j - CS%Iresttime_col(col) = G%US%T_to_s*Iresttime(i,j) + CS%Iresttime_col(col) = Iresttime(i,j) col = col +1 endif enddo ; enddo @@ -264,7 +264,7 @@ subroutine initialize_ALE_sponge_fixed(Iresttime, G, param_file, CS, data_h, nz_ 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) = G%US%T_to_s*Iresttime_u(i,j) + CS%Iresttime_col_u(col) = Iresttime_u(i,j) col = col +1 endif enddo ; enddo @@ -301,7 +301,7 @@ subroutine initialize_ALE_sponge_fixed(Iresttime, G, param_file, CS, data_h, nz_ 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) = G%US%T_to_s*Iresttime_v(i,j) + CS%Iresttime_col_v(col) = Iresttime_v(i,j) col = col +1 endif enddo ; enddo @@ -375,7 +375,7 @@ end subroutine get_ALE_sponge_thicknesses subroutine initialize_ALE_sponge_varying(Iresttime, G, param_file, 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 [s-1]. + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: Iresttime !< The inverse of the restoring time [T-1 ~> s-1]. type(param_file_type), intent(in) :: param_file !< A structure indicating the open file to parse !! for model parameter values. type(ALE_sponge_CS), pointer :: CS !< A pointer that is set to point to the control @@ -385,8 +385,8 @@ subroutine initialize_ALE_sponge_varying(Iresttime, G, param_file, CS) #include "version_variable.h" character(len=40) :: mdl = "MOM_sponge" ! This module's name. logical :: use_sponge - real, allocatable, dimension(:,:) :: Iresttime_u !< inverse of the restoring time at u points [s-1] - real, allocatable, dimension(:,:) :: Iresttime_v !< inverse of the restoring time at v points [s-1] + real, allocatable, dimension(:,:) :: Iresttime_u !< inverse of the restoring time at u points [T-1 ~> s-1] + real, allocatable, dimension(:,:) :: Iresttime_v !< inverse of the restoring time at v points [T-1 ~> s-1] logical :: bndExtrapolation = .true. ! If true, extrapolate boundaries logical :: spongeDataOngrid = .false. integer :: i, j, k, col, total_sponge_cols, total_sponge_cols_u, total_sponge_cols_v @@ -443,7 +443,7 @@ subroutine initialize_ALE_sponge_varying(Iresttime, G, param_file, CS) do j=G%jsc,G%jec ; do i=G%isc,G%iec if ((Iresttime(i,j)>0.0) .and. (G%mask2dT(i,j)>0)) then CS%col_i(col) = i ; CS%col_j(col) = j - CS%Iresttime_col(col) = G%US%T_to_s*Iresttime(i,j) + CS%Iresttime_col(col) = Iresttime(i,j) col = col +1 endif enddo ; enddo @@ -474,7 +474,7 @@ subroutine initialize_ALE_sponge_varying(Iresttime, G, param_file, CS) 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) = G%US%T_to_s*Iresttime_u(i,j) + CS%Iresttime_col_u(col) = Iresttime_u(i,j) col = col +1 endif enddo ; enddo @@ -500,7 +500,7 @@ subroutine initialize_ALE_sponge_varying(Iresttime, G, param_file, CS) 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) = G%US%T_to_s*Iresttime_v(i,j) + CS%Iresttime_col_v(col) = Iresttime_v(i,j) col = col +1 endif enddo ; enddo diff --git a/src/parameterizations/vertical/MOM_sponge.F90 b/src/parameterizations/vertical/MOM_sponge.F90 index 6016dbb98b..4566abcef7 100644 --- a/src/parameterizations/vertical/MOM_sponge.F90 +++ b/src/parameterizations/vertical/MOM_sponge.F90 @@ -89,7 +89,7 @@ subroutine initialize_sponge(Iresttime, int_height, G, param_file, CS, GV, & 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 !< The inverse of the restoring time [s-1]. + intent(in) :: Iresttime !< The inverse of the restoring time [T-1 ~> s-1]. real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1), & intent(in) :: int_height !< The interface heights to damp back toward [Z ~> m]. type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters @@ -98,7 +98,7 @@ subroutine initialize_sponge(Iresttime, int_height, G, param_file, CS, GV, & type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure real, dimension(SZJ_(G)), & optional, intent(in) :: Iresttime_i_mean !< The inverse of the restoring time for - !! the zonal mean properties [s-1]. + !! the zonal mean properties [T-1 ~> s-1]. real, dimension(SZJ_(G),SZK_(G)+1), & optional, intent(in) :: int_height_i_mean !< The interface heights toward which to !! damp the zonal mean heights [Z ~> m]. @@ -155,7 +155,7 @@ subroutine initialize_sponge(Iresttime, int_height, G, param_file, CS, GV, & do j=G%jsc,G%jec ; do i=G%isc,G%iec if ((Iresttime(i,j)>0.0) .and. (G%mask2dT(i,j)>0)) then CS%col_i(col) = i ; CS%col_j(col) = j - CS%Iresttime_col(col) = G%US%T_to_s*Iresttime(i,j) + CS%Iresttime_col(col) = Iresttime(i,j) col = col +1 endif enddo ; enddo @@ -172,7 +172,7 @@ subroutine initialize_sponge(Iresttime, int_height, G, param_file, CS, GV, & allocate(CS%Ref_eta_im(G%jsd:G%jed,G%ke+1)) ; CS%Ref_eta_im(:,:) = 0.0 do j=G%jsc,G%jec - CS%Iresttime_im(j) = G%US%T_to_s*Iresttime_i_mean(j) + CS%Iresttime_im(j) = Iresttime_i_mean(j) enddo do K=1,CS%nz+1 ; do j=G%jsc,G%jec CS%Ref_eta_im(j,K) = int_height_i_mean(j,K) diff --git a/src/user/BFB_initialization.F90 b/src/user/BFB_initialization.F90 index 546efcf0b9..9e8f612a35 100644 --- a/src/user/BFB_initialization.F90 +++ b/src/user/BFB_initialization.F90 @@ -91,10 +91,11 @@ subroutine BFB_initialize_sponges_southonly(G, GV, US, use_temperature, tv, para ! Local variables real :: eta(SZI_(G),SZJ_(G),SZK_(G)+1) ! A temporary array for eta, in depth units [Z ~> m]. - real :: Idamp(SZI_(G),SZJ_(G)) ! The inverse damping rate [s-1]. + real :: Idamp(SZI_(G),SZJ_(G)) ! The inverse damping rate [T-1 ~> s-1]. real :: H0(SZK_(G)) ! Resting layer thicknesses in depth units [Z ~> m]. real :: min_depth ! The minimum ocean depth in depth units [Z ~> m]. - real :: damp, e_dense, damp_new, slat, wlon, lenlat, lenlon, nlat + real :: slat, wlon, lenlat, lenlon, nlat + real :: max_damping ! The maximum damping rate [T-1 ~> s-1] character(len=40) :: mdl = "BFB_initialize_sponges_southonly" ! This subroutine's name. integer :: i, j, k, is, ie, js, je, isd, ied, jsd, jed, nz @@ -103,10 +104,10 @@ subroutine BFB_initialize_sponges_southonly(G, GV, US, use_temperature, tv, para eta(:,:,:) = 0.0 ; Idamp(:,:) = 0.0 -! Here the inverse damping time [s-1], is set. Set Idamp to 0 ! -! wherever there is no sponge, and the subroutines that are called ! -! will automatically set up the sponges only where Idamp is positive! -! and mask2dT is 1. ! +! Here the inverse damping time [T-1 ~> s-1], is set. Set Idamp to 0 +! wherever there is no sponge, and the subroutines that are called +! will automatically set up the sponges only where Idamp is positive +! and mask2dT is 1. ! Set up sponges for DOME configuration call get_param(param_file, mdl, "MINIMUM_DEPTH", min_depth, & @@ -126,11 +127,14 @@ subroutine BFB_initialize_sponges_southonly(G, GV, US, use_temperature, tv, para ! Use for meridional thickness profile initialization ! do k=1,nz ; H0(k) = -G%max_depth * real(k-1) / real(nz-1) ; enddo + max_damping = 1.0 / (86400.0*US%s_to_T) + do i=is,ie; do j=js,je - if (G%geoLatT(i,j) < slat+2.0) then ; damp = 1.0 + if (G%bathyT(i,j) <= min_depth) then ; Idamp(i,j) = 0.0 + elseif (G%geoLatT(i,j) < slat+2.0) then ; Idamp(i,j) = max_damping elseif (G%geoLatT(i,j) < slat+4.0) then - damp_new = 1.0*(slat+4.0-G%geoLatT(i,j))/2.0 - else ; damp = 0.0 + Idamp(i,j) = max_damping * (slat+4.0-G%geoLatT(i,j))/2.0 + else ; Idamp(i,j) = 0.0 endif ! These will be streched inside of apply_sponge, so they can be in @@ -153,9 +157,6 @@ subroutine BFB_initialize_sponges_southonly(G, GV, US, use_temperature, tv, para ! endif eta(i,j,nz+1) = -G%max_depth - if (G%bathyT(i,j) > min_depth) then - Idamp(i,j) = damp/86400.0 - else ; Idamp(i,j) = 0.0 ; endif enddo ; enddo ! This call sets up the damping rates and interface heights. diff --git a/src/user/DOME2d_initialization.F90 b/src/user/DOME2d_initialization.F90 index ddffbab1be..642ed41d88 100644 --- a/src/user/DOME2d_initialization.F90 +++ b/src/user/DOME2d_initialization.F90 @@ -353,9 +353,10 @@ subroutine DOME2d_initialize_temperature_salinity ( T, S, h, G, GV, param_file, end subroutine DOME2d_initialize_temperature_salinity !> Set up sponges in 2d DOME configuration -subroutine DOME2d_initialize_sponges(G, GV, tv, param_file, use_ALE, CSp, ACSp) - type(ocean_grid_type), intent(in) :: G !< Ocean grid structure +subroutine DOME2d_initialize_sponges(G, GV, US, tv, param_file, use_ALE, CSp, ACSp) + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamics structure type(param_file_type), intent(in) :: param_file !< Parameter file structure logical, intent(in) :: use_ALE !< If true, indicates model is in ALE mode @@ -367,7 +368,7 @@ subroutine DOME2d_initialize_sponges(G, GV, tv, param_file, use_ALE, CSp, ACSp) real :: RHO(SZI_(G),SZJ_(G),SZK_(G)) ! A temporary array for RHO [kg m-3] real :: h(SZI_(G),SZJ_(G),SZK_(G)) ! A temporary array for thickness [H ~> m or kg m-2]. real :: eta(SZI_(G),SZJ_(G),SZK_(G)+1) ! A temporary array for thickness [Z ~> m] - real :: Idamp(SZI_(G),SZJ_(G)) ! The inverse damping rate [s-1]. + real :: Idamp(SZI_(G),SZJ_(G)) ! The inverse damping rate [T-1 ~> s-1]. real :: S_ref, T_ref ! Reference salinity and temerature within surface layer real :: S_range, T_range ! Range of salinities and temperatures over the vertical real :: e0(SZK_(G)+1) ! The resting interface heights [Z ~> m], @@ -376,7 +377,7 @@ subroutine DOME2d_initialize_sponges(G, GV, tv, param_file, use_ALE, CSp, ACSp) ! positive upward [Z ~> m]. real :: d_eta(SZK_(G)) ! The layer thickness in a column [Z ~> m]. real :: dome2d_width_bay, dome2d_width_bottom, dome2d_depth_bay - real :: dome2d_west_sponge_time_scale, dome2d_east_sponge_time_scale + real :: dome2d_west_sponge_time_scale, dome2d_east_sponge_time_scale ! Sponge timescales [T ~> s] real :: dome2d_west_sponge_width, dome2d_east_sponge_width real :: dummy1, x, z integer :: i, j, k, is, ie, js, je, isd, ied, jsd, jed, nz @@ -387,11 +388,11 @@ subroutine DOME2d_initialize_sponges(G, GV, tv, param_file, use_ALE, CSp, ACSp) call get_param(param_file, mdl, "DOME2D_WEST_SPONGE_TIME_SCALE", dome2d_west_sponge_time_scale, & 'The time-scale on the west edge of the domain for restoring T/S '//& 'in the sponge. If zero, the western sponge is disabled', & - units='s', default=0.) + units='s', default=0., scale=US%s_to_T) call get_param(param_file, mdl, "DOME2D_EAST_SPONGE_TIME_SCALE", dome2d_east_sponge_time_scale, & 'The time-scale on the east edge of the domain for restoring T/S '//& 'in the sponge. If zero, the eastern sponge is disabled', & - units='s', default=0.) + units='s', default=0., scale=US%s_to_T) call get_param(param_file, mdl, "DOME2D_WEST_SPONGE_WIDTH", dome2d_west_sponge_width, & 'The fraction of the domain in which the western sponge for restoring T/S '//& 'is active.', & diff --git a/src/user/DOME_initialization.F90 b/src/user/DOME_initialization.F90 index cb30c09b6f..f582ca0c7a 100644 --- a/src/user/DOME_initialization.F90 +++ b/src/user/DOME_initialization.F90 @@ -157,13 +157,14 @@ subroutine DOME_initialize_sponges(G, GV, US, tv, PF, CSp) type(sponge_CS), pointer :: CSp !< A pointer that is set to point to the control !! structure for this module. - real :: eta(SZI_(G),SZJ_(G),SZK_(G)+1) ! A temporary array for eta. + real :: eta(SZI_(G),SZJ_(G),SZK_(G)+1) ! A temporary array for eta [Z ~> m]. real :: temp(SZI_(G),SZJ_(G),SZK_(G)) ! A temporary array for other variables. ! - real :: Idamp(SZI_(G),SZJ_(G)) ! The inverse damping rate [s-1]. + real :: Idamp(SZI_(G),SZJ_(G)) ! The inverse damping rate [T-1 ~> s-1]. real :: H0(SZK_(G)) ! Interface heights [Z ~> m]. - real :: min_depth - real :: damp, e_dense, damp_new + real :: min_depth ! The minimum depth at which to apply damping [Z ~> m] + real :: damp, damp_new ! Damping rates in the sponge [days] + real :: e_dense ! The depth of the densest interfaces [Z ~> m] character(len=40) :: mdl = "DOME_initialize_sponges" ! This subroutine's name. integer :: i, j, k, is, ie, js, je, isd, ied, jsd, jed, nz @@ -186,17 +187,18 @@ subroutine DOME_initialize_sponges(G, GV, US, tv, PF, CSp) do i=is,ie; do j=js,je if (G%geoLonT(i,j) < 100.0) then ; damp = 10.0 elseif (G%geoLonT(i,j) < 200.0) then - damp = 10.0*(200.0-G%geoLonT(i,j))/100.0 + damp = 10.0 * (200.0-G%geoLonT(i,j))/100.0 else ; damp=0.0 endif if (G%geoLonT(i,j) > 1400.0) then ; damp_new = 10.0 elseif (G%geoLonT(i,j) > 1300.0) then - damp_new = 10.0*(G%geoLonT(i,j)-1300.0)/100.0 + damp_new = 10.0 * (G%geoLonT(i,j)-1300.0)/100.0 else ; damp_new = 0.0 endif - if (damp <= damp_new) damp=damp_new + if (damp <= damp_new) damp = damp_new + damp = US%T_to_s*damp ! These will be stretched inside of apply_sponge, so they can be in ! depth space for Boussinesq or non-Boussinesq models. @@ -212,7 +214,7 @@ subroutine DOME_initialize_sponges(G, GV, US, tv, PF, CSp) eta(i,j,nz+1) = -G%bathyT(i,j) if (G%bathyT(i,j) > min_depth) then - Idamp(i,j) = damp/86400.0 + Idamp(i,j) = damp / 86400.0 else ; Idamp(i,j) = 0.0 ; endif enddo ; enddo diff --git a/src/user/ISOMIP_initialization.F90 b/src/user/ISOMIP_initialization.F90 index 5fb35fa939..1d14ff9cc5 100644 --- a/src/user/ISOMIP_initialization.F90 +++ b/src/user/ISOMIP_initialization.F90 @@ -437,12 +437,12 @@ subroutine ISOMIP_initialize_sponges(G, GV, US, tv, PF, use_ALE, CSp, ACSp) type(sponge_CS), pointer :: CSp !< Layer-mode sponge structure type(ALE_sponge_CS), pointer :: ACSp !< ALE-mode sponge structure ! Local variables - real :: T(SZI_(G),SZJ_(G),SZK_(G)) ! A temporary array for temp - real :: S(SZI_(G),SZJ_(G),SZK_(G)) ! A temporary array for salt - real :: RHO(SZI_(G),SZJ_(G),SZK_(G)) ! A temporary array for RHO - real :: h(SZI_(G),SZJ_(G),SZK_(G)) ! A temporary array for thickness - real :: Idamp(SZI_(G),SZJ_(G)) ! The inverse damping rate [s-1]. - real :: TNUDG ! Nudging time scale, days + real :: T(SZI_(G),SZJ_(G),SZK_(G)) ! A temporary array for temp [degC] + real :: S(SZI_(G),SZJ_(G),SZK_(G)) ! A temporary array for salt [ppt] + ! real :: RHO(SZI_(G),SZJ_(G),SZK_(G)) ! A temporary array for RHO [R ~> kg m-3] + real :: h(SZI_(G),SZJ_(G),SZK_(G)) ! A temporary array for thickness [H ~> m or kg m-2] + real :: Idamp(SZI_(G),SZJ_(G)) ! The inverse damping rate [T-1 ~> s-1]. + real :: TNUDG ! Nudging time scale [T ~> s] real :: S_sur, T_sur ! Surface salinity and temerature in sponge real :: S_bot, T_bot ! Bottom salinity and temerature in sponge real :: t_ref, s_ref ! reference T and S @@ -455,7 +455,7 @@ subroutine ISOMIP_initialize_sponges(G, GV, US, tv, PF, use_ALE, CSp, ACSp) real :: eta1D(SZK_(G)+1) ! Interface height relative to the sea surface, positive upward [Z ~> m]. real :: eta(SZI_(G),SZJ_(G),SZK_(G)+1) ! A temporary array for eta [Z ~> m]. real :: min_depth, dummy1, z - real :: damp, rho_dummy, min_thickness, rho_tmp, xi0 + real :: rho_dummy, min_thickness, rho_tmp, xi0 character(len=40) :: verticalCoordinate, filename, state_file character(len=40) :: temp_var, salt_var, eta_var, inputdir @@ -471,12 +471,13 @@ subroutine ISOMIP_initialize_sponges(G, GV, US, tv, PF, use_ALE, CSp, ACSp) call get_param(PF, mdl, "REGRIDDING_COORDINATE_MODE", verticalCoordinate, & default=DEFAULT_COORDINATE_MODE) - call get_param(PF, mdl, "ISOMIP_TNUDG", TNUDG, "Nudging time scale for sponge layers (days)", default=0.0) + call get_param(PF, mdl, "ISOMIP_TNUDG", TNUDG, "Nudging time scale for sponge layers (days)", & + default=0.0, scale=86400.0*US%s_to_T) - call get_param(PF, mdl, "T_REF", t_ref, "Reference temperature", default=10.0,& + call get_param(PF, mdl, "T_REF", t_ref, "Reference temperature", default=10.0, & do_not_log=.true.) - call get_param(PF, mdl, "S_REF", s_ref, "Reference salinity", default=35.0,& + call get_param(PF, mdl, "S_REF", s_ref, "Reference salinity", default=35.0, & do_not_log=.true.) call get_param(PF, mdl, "ISOMIP_S_SUR_SPONGE", s_sur, & @@ -491,7 +492,7 @@ subroutine ISOMIP_initialize_sponges(G, GV, US, tv, PF, use_ALE, CSp, ACSp) call get_param(PF, mdl, "ISOMIP_T_BOT_SPONGE", t_bot, & 'Bottom temperature in sponge layer.', default=t_ref) ! units="degC") - T(:,:,:) = 0.0 ; S(:,:,:) = 0.0 ; Idamp(:,:) = 0.0; RHO(:,:,:) = 0.0 + T(:,:,:) = 0.0 ; S(:,:,:) = 0.0 ; Idamp(:,:) = 0.0 !; RHO(:,:,:) = 0.0 ! Set up sponges for ISOMIP configuration call get_param(PF, mdl, "MINIMUM_DEPTH", min_depth, & @@ -502,26 +503,21 @@ subroutine ISOMIP_initialize_sponges(G, GV, US, tv, PF, use_ALE, CSp, ACSp) if (associated(ACSp)) call MOM_error(FATAL, & "ISOMIP_initialize_sponges called with an associated ALE-sponge control structure.") - ! Here the inverse damping time [s-1], is set. Set Idamp to 0 ! - ! wherever there is no sponge, and the subroutines that are called ! - ! will automatically set up the sponges only where Idamp is positive! + ! Here the inverse damping time [T-1 ~> s-1], is set. Set Idamp to 0 + ! wherever there is no sponge, and the subroutines that are called + ! will automatically set up the sponges only where Idamp is positive ! and mask2dT is 1. do i=is,ie; do j=js,je - if (G%geoLonT(i,j) >= 790.0 .AND. G%geoLonT(i,j) <= 800.0) then - - ! 1 / day - dummy1=(G%geoLonT(i,j)-790.0)/(800.0-790.0) - damp = 1.0/TNUDG * max(0.0,dummy1) - - else ; damp=0.0 + if (G%bathyT(i,j) <= min_depth) then + Idamp(i,j) = 0.0 + elseif (G%geoLonT(i,j) >= 790.0 .AND. G%geoLonT(i,j) <= 800.0) then + dummy1 = (G%geoLonT(i,j)-790.0)/(800.0-790.0) + Idamp(i,j) = (1.0/TNUDG) * max(0.0,dummy1) + else + Idamp(i,j) = 0.0 endif - ! convert to 1 / seconds - if (G%bathyT(i,j) > min_depth) then - Idamp(i,j) = damp/86400.0 - else ; Idamp(i,j) = 0.0 ; endif - enddo ; enddo ! Compute min/max density using T_SUR/S_SUR and T_BOT/S_BOT diff --git a/src/user/Phillips_initialization.F90 b/src/user/Phillips_initialization.F90 index 29e049c9b6..5cd75725e3 100644 --- a/src/user/Phillips_initialization.F90 +++ b/src/user/Phillips_initialization.F90 @@ -166,8 +166,8 @@ subroutine Phillips_initialize_velocity(u, v, G, GV, US, param_file, just_read_p do k=nz-1,1 ; do j=js,je ; do I=is-1,ie y_2 = G%geoLatCu(I,j) - G%south_lat - 0.5*G%len_lat ! This uses d/d y_2 atan(y_2 / jet_width) -! u(I,j,k) = u(I,j,k+1) + (1e-3 * jet_height / & -! (US%m_to_L*jet_width * (1.0 + (y_2 / jet_width)**2))) * & +! u(I,j,k) = u(I,j,k+1) + ( jet_height / & +! (1.0e3*US%m_to_L*jet_width * (1.0 + (y_2 / jet_width)**2))) * & ! (2.0 * GV%g_prime(K+1) / (G%CoriolisBu(I,J) + G%CoriolisBu(I,J-1))) ! This uses d/d y_2 tanh(y_2 / jet_width) u(I,j,k) = u(I,j,k+1) + (1e-3 * (jet_height / (US%m_to_L*jet_width)) * & @@ -219,10 +219,10 @@ subroutine Phillips_initialize_sponges(G, GV, US, tv, param_file, CSp, h) real :: eta0(SZK_(G)+1) ! The 1-d nominal positions of the interfaces. real :: eta(SZI_(G),SZJ_(G),SZK_(G)+1) ! A temporary array for eta [Z ~> m]. real :: temp(SZI_(G),SZJ_(G),SZK_(G)) ! A temporary array for other variables. - real :: Idamp(SZI_(G),SZJ_(G)) ! The inverse damping rate [s-1]. + real :: Idamp(SZI_(G),SZJ_(G)) ! The inverse damping rate [T-1 ~> s-1]. real :: eta_im(SZJ_(G),SZK_(G)+1) ! A temporary array for zonal-mean eta [Z ~> m]. - real :: Idamp_im(SZJ_(G)) ! The inverse zonal-mean damping rate [s-1]. - real :: damp_rate ! The inverse zonal-mean damping rate [s-1]. + real :: Idamp_im(SZJ_(G)) ! The inverse zonal-mean damping rate [T-1 ~> s-1]. + real :: damp_rate ! The inverse zonal-mean damping rate [T-1 ~> s-1]. real :: jet_width ! The width of the zonal mean jet, in km. real :: jet_height ! The interface height scale associated with the zonal-mean jet [Z ~> m]. real :: y_2 ! The y-position relative to the channel center, in km. @@ -246,7 +246,7 @@ subroutine Phillips_initialize_sponges(G, GV, US, tv, param_file, CSp, h) units="nondim", default = 0.5) call get_param(param_file, mdl, "SPONGE_RATE", damp_rate, & "The rate at which the zonal-mean sponges damp.", units="s-1", & - default = 1.0/(10.0*86400.0)) + default = 1.0/(10.0*86400.0), scale=US%T_to_s) call get_param(param_file, mdl, "JET_WIDTH", jet_width, & "The width of the zonal-mean jet.", units="km", & diff --git a/src/user/RGC_initialization.F90 b/src/user/RGC_initialization.F90 index f84a634976..ae28bb36c6 100644 --- a/src/user/RGC_initialization.F90 +++ b/src/user/RGC_initialization.F90 @@ -75,8 +75,8 @@ subroutine RGC_initialize_sponges(G, GV, US, tv, u, v, PF, use_ALE, CSp, ACSp) real :: RHO(SZI_(G),SZJ_(G),SZK_(G)) ! A temporary array for RHO real :: tmp(SZI_(G),SZJ_(G)) ! A temporary array for tracers. real :: h(SZI_(G),SZJ_(G),SZK_(G)) ! A temporary array for thickness at h points - real :: Idamp(SZI_(G),SZJ_(G)) ! The inverse damping rate at h points [s-1]. - real :: TNUDG ! Nudging time scale, days + real :: Idamp(SZI_(G),SZJ_(G)) ! The inverse damping rate at h points [T-1 ~> s-1]. + real :: TNUDG ! Nudging time scale [T ~> s] real :: pres(SZI_(G)) ! An array of the reference pressure, in Pa real :: e0(SZK_(G)+1) ! The resting interface heights, in m, usually ! ! negative because it is positive upward. ! @@ -84,7 +84,7 @@ subroutine RGC_initialize_sponges(G, GV, US, tv, u, v, PF, use_ALE, CSp, ACSp) ! positive upward, in m. logical :: sponge_uv ! Nudge velocities (u and v) towards zero real :: min_depth, dummy1, z, delta_h - real :: damp, rho_dummy, min_thickness, rho_tmp, xi0 + real :: rho_dummy, min_thickness, rho_tmp, xi0 real :: lenlat, lenlon, lensponge character(len=40) :: filename, state_file character(len=40) :: temp_var, salt_var, eta_var, inputdir, h_var @@ -98,7 +98,8 @@ subroutine RGC_initialize_sponges(G, GV, US, tv, u, v, PF, use_ALE, CSp, ACSp) call get_param(PF,mod,"MIN_THICKNESS",min_thickness,'Minimum layer thickness',units='m',default=1.e-3) - call get_param(PF, mod, "RGC_TNUDG", TNUDG, 'Nudging time scale for sponge layers (days)', default=0.0) + call get_param(PF, mod, "RGC_TNUDG", TNUDG, 'Nudging time scale for sponge layers (days)', & + default=0.0, scale=86400.0*US%s_to_T) call get_param(PF, mod, "LENLAT", lenlat, & "The latitudinal or y-direction length of the domain", & @@ -126,31 +127,20 @@ subroutine RGC_initialize_sponges(G, GV, US, tv, u, v, PF, use_ALE, CSp, ACSp) if (associated(ACSp)) call MOM_error(FATAL, & "RGC_initialize_sponges called with an associated ALE-sponge control structure.") - ! Here the inverse damping time, in s-1, is set. Set Idamp to 0 ! - ! wherever there is no sponge, and the subroutines that are called ! - ! will automatically set up the sponges only where Idamp is positive! + ! Here the inverse damping time [T-1 ~> s-1], is set. Set Idamp to 0 + ! wherever there is no sponge, and the subroutines that are called + ! will automatically set up the sponges only where Idamp is positive ! and mask2dT is 1. do i=is,ie ; do j=js,je - if (G%geoLonT(i,j) <= lensponge) then - dummy1 = -(G%geoLonT(i,j))/lensponge + 1.0 - !damp = 1.0/TNUDG * max(0.0,dummy1) - damp = 0.0 - !write(*,*)'1st, G%geoLonT(i,j), damp',G%geoLonT(i,j), damp - + if ((G%bathyT(i,j) <= min_depth) .or. (G%geoLonT(i,j) <= lensponge)) then + Idamp(i,j) = 0.0 elseif (G%geoLonT(i,j) >= (lenlon - lensponge) .AND. G%geoLonT(i,j) <= lenlon) then - -! 1 / day - dummy1=(G%geoLonT(i,j)-(lenlon - lensponge))/(lensponge) - damp = (1.0/TNUDG) * max(0.0,dummy1) - - else ; damp=0.0 + dummy1 = (G%geoLonT(i,j)-(lenlon - lensponge))/(lensponge) + Idamp(i,j) = (1.0/TNUDG) * max(0.0,dummy1) + else + Idamp(i,j) = 0.0 endif - -! convert to 1 / seconds - if (G%bathyT(i,j) > min_depth) then - Idamp(i,j) = damp/86400.0 - else ; Idamp(i,j) = 0.0 ; endif enddo ; enddo diff --git a/src/user/dense_water_initialization.F90 b/src/user/dense_water_initialization.F90 index 2233adb1a3..d591db30fb 100644 --- a/src/user/dense_water_initialization.F90 +++ b/src/user/dense_water_initialization.F90 @@ -150,21 +150,24 @@ subroutine dense_water_initialize_TS(G, GV, param_file, eqn_of_state, T, S, h, j end subroutine dense_water_initialize_TS !> Initialize the restoring sponges for the dense water experiment -subroutine dense_water_initialize_sponges(G, GV, tv, param_file, use_ALE, CSp, ACSp) +subroutine dense_water_initialize_sponges(G, GV, US, tv, param_file, use_ALE, CSp, ACSp) type(ocean_grid_type), intent(in) :: G !< Horizontal grid control structure type(verticalGrid_type), intent(in) :: GV !< Vertical grid control structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamic variables type(param_file_type), intent(in) :: param_file !< Parameter file structure logical, intent(in) :: use_ALE !< ALE flag type(sponge_CS), pointer :: CSp !< Layered sponge control structure pointer type(ALE_sponge_CS), pointer :: ACSp !< ALE sponge control structure pointer ! Local variables - real :: west_sponge_time_scale, west_sponge_width - real :: east_sponge_time_scale, east_sponge_width + real :: west_sponge_time_scale, east_sponge_time_scale ! Sponge timescales [T ~> s] + real :: west_sponge_width, east_sponge_width - real, dimension(SZI_(G),SZJ_(G)) :: Idamp ! inverse damping timescale - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: h, T, S ! sponge thicknesses, temp and salt - real, dimension(SZK_(GV)+1) :: e0, eta1D ! interface positions for ALE sponge + real, dimension(SZI_(G),SZJ_(G)) :: Idamp ! inverse damping timescale [T-1 ~> s-1] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: h ! sponge thicknesses [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: T ! sponge temperature [degC] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: S ! sponge salinity [ppt] + real, dimension(SZK_(GV)+1) :: e0, eta1D ! interface positions for ALE sponge [Z ~> m] integer :: i, j, k, nz real :: x, zi, zmid, dist @@ -174,13 +177,13 @@ subroutine dense_water_initialize_sponges(G, GV, tv, param_file, use_ALE, CSp, A call get_param(param_file, mdl, "DENSE_WATER_WEST_SPONGE_TIME_SCALE", west_sponge_time_scale, & "The time scale on the west (outflow) of the domain for restoring. If zero, the sponge is disabled.", & - units="s", default=0.) + units="s", default=0., scale=US%s_to_T) call get_param(param_file, mdl, "DENSE_WATER_WEST_SPONGE_WIDTH", west_sponge_width, & "The fraction of the domain in which the western (outflow) sponge is active.", & units="nondim", default=0.1) call get_param(param_file, mdl, "DENSE_WATER_EAST_SPONGE_TIME_SCALE", east_sponge_time_scale, & "The time scale on the east (outflow) of the domain for restoring. If zero, the sponge is disabled.", & - units="s", default=0.) + units="s", default=0., scale=US%s_to_T) call get_param(param_file, mdl, "DENSE_WATER_EAST_SPONGE_WIDTH", east_sponge_width, & "The fraction of the domain in which the eastern (outflow) sponge is active.", & units="nondim", default=0.1) diff --git a/src/user/dumbbell_initialization.F90 b/src/user/dumbbell_initialization.F90 index b16b3a341c..6fa0dcafed 100644 --- a/src/user/dumbbell_initialization.F90 +++ b/src/user/dumbbell_initialization.F90 @@ -269,15 +269,16 @@ subroutine dumbbell_initialize_sponges(G, GV, US, tv, param_file, use_ALE, CSp, type(sponge_CS), pointer :: CSp !< Layered sponge control structure pointer type(ALE_sponge_CS), pointer :: ACSp !< ALE sponge control structure pointer - real :: sponge_time_scale + real :: sponge_time_scale ! The damping time scale [T ~> s] - real, dimension(SZI_(G),SZJ_(G)) :: Idamp ! inverse damping timescale + real, dimension(SZI_(G),SZJ_(G)) :: Idamp ! inverse damping timescale [T-1 ~> s-1] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: h, T, S ! sponge thicknesses, temp and salt real, dimension(SZK_(GV)+1) :: e0, eta1D ! interface positions for ALE sponge integer :: i, j, k, nz real :: x, zi, zmid, dist, min_thickness, dblen real :: mld, S_ref, S_range, S_dense, T_ref, sill_height + call get_param(param_file, mdl,"DUMBBELL_LEN",dblen, & 'Lateral Length scale for dumbbell ',& units='k', default=600., do_not_log=.true.) @@ -290,7 +291,7 @@ subroutine dumbbell_initialize_sponges(G, GV, US, tv, param_file, use_ALE, CSp, call get_param(param_file, mdl, "DUMBBELL_SPONGE_TIME_SCALE", sponge_time_scale, & "The time scale in the reservoir for restoring. If zero, the sponge is disabled.", & - units="s", default=0.) + units="s", default=0., scale=US%s_to_T) call get_param(param_file, mdl, "DUMBBELL_SREF", S_ref, do_not_log=.true.) call get_param(param_file, mdl, "DUMBBELL_S_RANGE", S_range, do_not_log=.true.) call get_param(param_file, mdl,"MIN_THICKNESS", min_thickness, & From c671e4928a74a779697e93715a86c55236992ee6 Mon Sep 17 00:00:00 2001 From: Kate Hedstrom Date: Fri, 13 Dec 2019 15:19:04 -0900 Subject: [PATCH 004/316] *Added SIMPLE_GRAD OBC option. - This is perhaps redundant in that the model was already loading dudy or dvdx if they were provided. - Turns out the model was reading them, but not loading them into the segment%tangential_grad array. --- src/core/MOM_open_boundary.F90 | 53 ++++++++++++++++++++++------------ 1 file changed, 34 insertions(+), 19 deletions(-) diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index d964c65145..223551674e 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -118,6 +118,7 @@ module MOM_open_boundary 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 :: specified_grad !< Boundary gradient of 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 any external OBC fields are needed. @@ -436,6 +437,7 @@ subroutine open_boundary_config(G, US, param_file, OBC) OBC%segment(l)%nudged_grad = .false. OBC%segment(l)%specified = .false. OBC%segment(l)%specified_tan = .false. + OBC%segment(l)%specified_grad = .false. OBC%segment(l)%open = .false. OBC%segment(l)%gradient = .false. OBC%segment(l)%values_needed = .false. @@ -941,6 +943,10 @@ subroutine setup_u_point_obc(OBC, G, US, segment_str, l_seg, PF, reentrant_y) OBC%segment%u_values_needed = .true. elseif (trim(action_str(a_loop)) == 'SIMPLE_TAN') then OBC%segment(l_seg)%specified_tan = .true. + OBC%segment%v_values_needed = .true. + elseif (trim(action_str(a_loop)) == 'SIMPLE_GRAD') then + OBC%segment(l_seg)%specified_grad = .true. + OBC%segment%g_values_needed = .true. else call MOM_error(FATAL, "MOM_open_boundary.F90, setup_u_point_obc: "//& "String '"//trim(action_str(a_loop))//"' not understood.") @@ -1078,6 +1084,10 @@ subroutine setup_v_point_obc(OBC, G, US, segment_str, l_seg, PF, reentrant_x) OBC%segment%v_values_needed = .true. elseif (trim(action_str(a_loop)) == 'SIMPLE_TAN') then OBC%segment(l_seg)%specified_tan = .true. + OBC%segment%v_values_needed = .true. + elseif (trim(action_str(a_loop)) == 'SIMPLE_GRAD') then + OBC%segment(l_seg)%specified_grad = .true. + OBC%segment%g_values_needed = .true. else call MOM_error(FATAL, "MOM_open_boundary.F90, setup_v_point_obc: "//& "String '"//trim(action_str(a_loop))//"' not understood.") @@ -3211,7 +3221,7 @@ subroutine allocate_OBC_segment_data(OBC, segment) 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 .or. & - segment%oblique_grad) then + segment%oblique_grad .or. segment%specified_grad) then allocate(segment%tangential_grad(IsdB:IedB,JsdB:JedB,OBC%ke)); segment%tangential_grad(:,:,:)=0.0 endif if (segment%oblique) then @@ -3254,7 +3264,7 @@ subroutine allocate_OBC_segment_data(OBC, segment) 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 .or. & - segment%oblique_grad) then + segment%oblique_grad .or. segment%specified_grad) then allocate(segment%tangential_grad(IsdB:IedB,JsdB:JedB,OBC%ke)); segment%tangential_grad(:,:,:)=0.0 endif if (segment%oblique) then @@ -3761,8 +3771,9 @@ subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) 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 (segment%field(m)%fid>0) then + ! calculate external BT velocity and transport if needed + if (trim(segment%field(m)%name) == 'U' .or. trim(segment%field(m)%name) == 'V') then if (trim(segment%field(m)%name) == 'U' .and. segment%is_E_or_W) then I=is_obc do j=js_obc+1,je_obc @@ -3809,23 +3820,27 @@ subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) 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) = US%T_to_s*segment%field(m)%buffer_dst(I,J,k) - enddo + endif + 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) = US%T_to_s*segment%field(m)%buffer_dst(I,J,k) + if (associated(segment%nudged_tangential_grad)) & + segment%nudged_tangential_grad(I,J,:) = segment%tangential_grad(I,J,:) 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) = US%T_to_s*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) = US%T_to_s*segment%field(m)%buffer_dst(I,J,k) + if (associated(segment%nudged_tangential_grad)) & + segment%nudged_tangential_grad(I,J,:) = segment%tangential_grad(I,J,:) enddo - endif + enddo endif endif From b330d95d88b4a8d74639f442579f63082afb02f8 Mon Sep 17 00:00:00 2001 From: Kate Hedstrom Date: Fri, 13 Dec 2019 15:38:52 -0900 Subject: [PATCH 005/316] Fix small OBC typo in last commit. --- src/core/MOM_open_boundary.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index 223551674e..0573886c3e 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -1084,7 +1084,7 @@ subroutine setup_v_point_obc(OBC, G, US, segment_str, l_seg, PF, reentrant_x) OBC%segment%v_values_needed = .true. elseif (trim(action_str(a_loop)) == 'SIMPLE_TAN') then OBC%segment(l_seg)%specified_tan = .true. - OBC%segment%v_values_needed = .true. + OBC%segment%u_values_needed = .true. elseif (trim(action_str(a_loop)) == 'SIMPLE_GRAD') then OBC%segment(l_seg)%specified_grad = .true. OBC%segment%g_values_needed = .true. From 4cd721f851ccb8b34dd7bb9d64c92171f7c6087c Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Mon, 16 Dec 2019 10:39:31 -0500 Subject: [PATCH 006/316] Fixed thickness_diffuse diagnostic array extents Corrected the vertical array extents and case of the k index for layer-located arrays drdi_u and drdj_v used in the interface-height diffusion energy release diagnostics. All answers are bitwise identical. --- .../lateral/MOM_thickness_diffuse.F90 | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/src/parameterizations/lateral/MOM_thickness_diffuse.F90 b/src/parameterizations/lateral/MOM_thickness_diffuse.F90 index a567edb4be..ed21cac347 100644 --- a/src/parameterizations/lateral/MOM_thickness_diffuse.F90 +++ b/src/parameterizations/lateral/MOM_thickness_diffuse.F90 @@ -587,8 +587,8 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV real :: drdjA, drdjB ! gradients in the layers above (A) and below(B) the ! interface times the grid spacing [R ~> kg m-3]. real :: drdkL, drdkR ! Vertical density differences across an interface [R ~> kg m-3]. - real :: drdi_u(SZIB_(G), SZK_(G)+1) ! Copy of drdi at u-points [R ~> kg m-3]. - real :: drdj_v(SZI_(G), SZK_(G)+1) ! Copy of drdj at v-points [R ~> kg m-3]. + real :: drdi_u(SZIB_(G), SZK_(G)) ! Copy of drdi at u-points [R ~> kg m-3]. + real :: drdj_v(SZI_(G), SZK_(G)) ! Copy of drdj at v-points [R ~> kg m-3]. real :: drdkDe_u(SZIB_(G),SZK_(G)+1) ! Lateral difference of product of drdk and e at u-points ! [Z R ~> kg m-2]. real :: drdkDe_v(SZI_(G),SZK_(G)+1) ! Lateral difference of product of drdk and e at v-points @@ -764,7 +764,7 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV drdkDe_u(I,K) = drdkR * e(i+1,j,K) - drdkL * e(i,j,K) endif - if (find_work) drdi_u(I,K) = drdiB + if (find_work) drdi_u(I,k) = drdiB if (k > nk_linear) then if (use_EOS) then @@ -955,7 +955,7 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV Work_u(I,j) = Work_u(I,j) + G_scale * & ( uhtot(I,j) * drdkDe_u(I,K) - & - (uhD(I,j,K) * drdi_u(I,K)) * 0.25 * & + (uhD(I,j,k) * drdi_u(I,k)) * 0.25 * & ((e(i,j,K) + e(i,j,K+1)) + (e(i+1,j,K) + e(i+1,j,K+1))) ) endif @@ -1014,7 +1014,7 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV drdkDe_v(i,K) = drdkR * e(i,j+1,K) - drdkL * e(i,j,K) endif - if (find_work) drdj_v(i,K) = drdjB + if (find_work) drdj_v(i,k) = drdjB if (k > nk_linear) then if (use_EOS) then @@ -1204,7 +1204,7 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV Work_v(i,J) = Work_v(i,J) + G_scale * & ( vhtot(i,J) * drdkDe_v(i,K) - & - (vhD(i,J,K) * drdj_v(i,K)) * 0.25 * & + (vhD(i,J,k) * drdj_v(i,k)) * 0.25 * & ((e(i,j,K) + e(i,j,K+1)) + (e(i,j+1,K) + e(i,j+1,K+1))) ) endif From 01fd87ed7dc232e93e50e861a4ea0b778da909b6 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Mon, 16 Dec 2019 10:41:16 -0500 Subject: [PATCH 007/316] Earlier rescaling of GEOTHERMAL_THICKNESS Rescaled the internal units of GEOTHERMAL_THICKNESS to [H] via rescaling when they are originally set via a get_param call, instead of rescaling later, for code simplification. All answers are bitwise identical. --- src/parameterizations/vertical/MOM_geothermal.F90 | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/parameterizations/vertical/MOM_geothermal.F90 b/src/parameterizations/vertical/MOM_geothermal.F90 index dba311441e..649d59e619 100644 --- a/src/parameterizations/vertical/MOM_geothermal.F90 +++ b/src/parameterizations/vertical/MOM_geothermal.F90 @@ -28,7 +28,7 @@ module MOM_geothermal !! of moving upward between layers [R degC-1 ~> kg m-3 degC-1]. real, pointer :: geo_heat(:,:) => NULL() !< The geothermal heat flux [J m-2 T-1 ~> W m-2]. real :: geothermal_thick !< The thickness over which geothermal heating is - !! applied [m] (not [H]). + !! applied [H ~> m or kg m-2]. 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. @@ -46,7 +46,7 @@ module MOM_geothermal !> Applies geothermal heating, including the movement of water !! between isopycnal layers to match the target densities. The heating is -!! applied to the bottommost layers that occur within ### of the bottom. If +!! applied to the bottommost layers that occur within GEOTHERMAL_THICKNESS of the bottom. If !! the partial derivative of the coordinate density with temperature is positive !! or very small, the layers are simply heated in place. Any heat that can not !! be applied to the ocean is returned (WHERE)? @@ -188,7 +188,7 @@ subroutine geothermal(h, tv, dt, ea, eb, G, GV, US, CS, halo) heat_rem(i) = G%mask2dT(i,j) * (CS%geo_heat(i,j) * (dt*Irho_cp)) do_i(i) = .true. ; if (heat_rem(i) <= 0.0) do_i(i) = .false. if (do_i(i)) num_start = num_start + 1 - h_geo_rem(i) = CS%Geothermal_thick * GV%m_to_H + h_geo_rem(i) = CS%Geothermal_thick enddo if (num_start == 0) cycle num_left = num_start @@ -422,7 +422,7 @@ subroutine geothermal_init(Time, G, GV, US, param_file, diag, CS) "read, or blank to use a constant heating rate.", default=" ") call get_param(param_file, mdl, "GEOTHERMAL_THICKNESS", CS%geothermal_thick, & "The thickness over which to apply geothermal heating.", & - units="m", default=0.1) + units="m", default=0.1, scale=GV%m_to_H) call get_param(param_file, mdl, "GEOTHERMAL_DRHO_DT_INPLACE", CS%dRcv_dT_inplace, & "The value of drho_dT above which geothermal heating "//& "simply heats water in place instead of moving it between "//& From d197c30069e235f1e6c91c60806acf5b5f696d65 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Mon, 16 Dec 2019 11:10:19 -0500 Subject: [PATCH 008/316] Changed small-N code in add_int_tide_diffusivity Reformulated the calculation of z_from_bot_WKB in add_int_tide_diffusivity to avoid using a hard-coded dimensional minimum vertical-mean stratification to handle the case of unstratified water columns, instead using an appropriate nondimensional scaling. This new code is only used if TIDAL_MIXING_2018_ANSWERS is false, but it can change answers in that case. --- .../vertical/MOM_tidal_mixing.F90 | 15 +++++++++++---- 1 file changed, 11 insertions(+), 4 deletions(-) diff --git a/src/parameterizations/vertical/MOM_tidal_mixing.F90 b/src/parameterizations/vertical/MOM_tidal_mixing.F90 index 887cc6d067..73c324974b 100644 --- a/src/parameterizations/vertical/MOM_tidal_mixing.F90 +++ b/src/parameterizations/vertical/MOM_tidal_mixing.F90 @@ -1294,10 +1294,17 @@ subroutine add_int_tide_diffusivity(h, N2_bot, j, TKE_to_Kd, max_TKE, G, GV, US, do k=nz-1,2,-1 ; do i=is,ie if (max_TKE(i,k) <= 0.0) cycle z_from_bot(i) = z_from_bot(i) + GV%H_to_Z*h(i,j,k) - if (N2_meanz(i) > 1.0e-14*US%T_to_s**2 ) then - z_from_bot_WKB(i) = z_from_bot_WKB(i) & - + GV%H_to_Z * h(i,j,k) * N2_lay(i,k) / N2_meanz(i) - else ; z_from_bot_WKB(i) = 0 ; endif + if (CS%answers_2018) then + if (N2_meanz(i) > 1.0e-14*US%T_to_s**2 ) then + z_from_bot_WKB(i) = z_from_bot_WKB(i) & + + GV%H_to_Z * h(i,j,k) * N2_lay(i,k) / N2_meanz(i) + else ; z_from_bot_WKB(i) = 0 ; endif + else + if (GV%H_to_Z*h(i,j,k) * N2_lay(i,k) < (1.0e14 * htot_WKB(i)) * N2_meanz(i)) then + z_from_bot_WKB(i) = z_from_bot_WKB(i) + & + GV%H_to_Z*h(i,j,k) * N2_lay(i,k) / N2_meanz(i) + endif + endif ! Fraction of bottom flux predicted to reach top of this layer TKE_frac_top(i) = ( Inv_int(i) * z0_polzin_scaled(i) ) / & From f96534fc6436e9fcb4dec95634ac37c907cb268a Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Tue, 17 Dec 2019 07:55:17 -0500 Subject: [PATCH 009/316] +(*)Reformulated regridding code Extensively revised the code in the 4 regridding modules for accuracy and stability. These changes include the addition of the new subroutine solve_diag_dominant_tridiag and removing an unused argument from edge_values_explicit_h2. The new optional argument answers_2018 was added to to P1M_interpolation, PPM_reconstruction, PPM_limiter_standard, P3M_interpolation, P3M_limiter, PQM_reconstruction, PQM_limiter, solve_linear_system, solve_tridiagonal_system, and bound_edge_values. All of these changes are only used when the regridding is called with the optional argument answers_2018 set to false. By default all answers are bitwise identical, but there are several changes to externally visible interfaces. --- src/ALE/P1M_functions.F90 | 30 +- src/ALE/P3M_functions.F90 | 11 +- src/ALE/PPM_functions.F90 | 49 ++- src/ALE/PQM_functions.F90 | 78 ++--- src/ALE/regrid_edge_slopes.F90 | 247 ++++++++----- src/ALE/regrid_edge_values.F90 | 622 ++++++++++++++++----------------- src/ALE/regrid_interp.F90 | 130 +++---- src/ALE/regrid_solvers.F90 | 232 +++++++----- 8 files changed, 742 insertions(+), 657 deletions(-) diff --git a/src/ALE/P1M_functions.F90 b/src/ALE/P1M_functions.F90 index 0a0d842581..f2c85d9872 100644 --- a/src/ALE/P1M_functions.F90 +++ b/src/ALE/P1M_functions.F90 @@ -24,23 +24,22 @@ module P1M_functions !! !! 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. -subroutine P1M_interpolation( N, h, u, ppoly_E, ppoly_coef, h_neglect ) +subroutine P1M_interpolation( N, h, u, ppoly_E, ppoly_coef, h_neglect, answers_2018 ) 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) :: ppoly_E !< Potentially modified edge values, - !! with the same units as u. + real, dimension(:), intent(in) :: h !< cell widths (size N) [H] + real, dimension(:), intent(in) :: u !< cell average properties (size N) [A] + real, dimension(:,:), intent(inout) :: ppoly_E !< Potentially modified edge values [A] 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 - !! in the same units as h. + !! piecewise polynomial coefficients, mainly [A] + real, optional, intent(in) :: h_neglect !< A negligibly small width [H] + logical, optional, intent(in) :: answers_2018 !< If true use older, less acccurate expressions. + ! Local variables integer :: k ! loop index real :: u0_l, u0_r ! edge values (left and right) ! Bound edge values (routine found in 'edge_values.F90') - call bound_edge_values( N, h, u, ppoly_E, h_neglect ) + call bound_edge_values( N, h, u, ppoly_E, h_neglect, answers_2018 ) ! Systematically average discontinuous edge values (routine found in ! 'edge_values.F90') @@ -69,12 +68,11 @@ end subroutine P1M_interpolation subroutine P1M_boundary_extrapolation( N, h, u, ppoly_E, ppoly_coef ) ! 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 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, dimension(:), intent(in) :: h !< cell widths (size N) [H] + real, dimension(:), intent(in) :: u !< cell averages (size N) [A] + real, dimension(:,:), intent(inout) :: ppoly_E !< edge values of piecewise polynomials [A] + real, dimension(:,:), intent(inout) :: ppoly_coef !< coefficients of piecewise polynomials, mainly [A] + ! Local variables real :: u0, u1 ! cell averages real :: h0, h1 ! corresponding cell widths diff --git a/src/ALE/P3M_functions.F90 b/src/ALE/P3M_functions.F90 index da3fe5bb6b..3ea756b7c3 100644 --- a/src/ALE/P3M_functions.F90 +++ b/src/ALE/P3M_functions.F90 @@ -25,7 +25,7 @@ module P3M_functions !! !! 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. -subroutine P3M_interpolation( N, h, u, ppoly_E, ppoly_S, ppoly_coef, h_neglect ) +subroutine P3M_interpolation( N, h, u, ppoly_E, ppoly_S, ppoly_coef, h_neglect, answers_2018 ) integer, intent(in) :: N !< Number of cells real, dimension(:), intent(in) :: h !< cell widths (size N) [H] real, dimension(:), intent(in) :: u !< cell averages (size N) in arbitrary units [A] @@ -34,13 +34,14 @@ subroutine P3M_interpolation( N, h, u, ppoly_E, ppoly_S, ppoly_coef, h_neglect ) real, dimension(:,:), intent(inout) :: ppoly_coef !< Coefficients of polynomial [A] real, optional, intent(in) :: h_neglect !< A negligibly small width for the !! purpose of cell reconstructions [H] + logical, optional, intent(in) :: answers_2018 !< If true use older, less acccurate expressions. ! Call the limiter for p3m, which takes care of everything from ! computing the coefficients of the cubic to monotonizing it. ! This routine could be called directly instead of having to call ! 'P3M_interpolation' first but we do that to provide an homogeneous ! interface. - call P3M_limiter( N, h, u, ppoly_E, ppoly_S, ppoly_coef, h_neglect ) + call P3M_limiter( N, h, u, ppoly_E, ppoly_S, ppoly_coef, h_neglect, answers_2018 ) end subroutine P3M_interpolation @@ -57,7 +58,7 @@ end subroutine P3M_interpolation !! c. If not, monotonize cubic curve and rebuild it !! !! Step 3 of the monotonization process leaves all edge values unchanged. -subroutine P3M_limiter( N, h, u, ppoly_E, ppoly_S, ppoly_coef, h_neglect ) +subroutine P3M_limiter( N, h, u, ppoly_E, ppoly_S, ppoly_coef, h_neglect, answers_2018 ) integer, intent(in) :: N !< Number of cells real, dimension(:), intent(in) :: h !< cell widths (size N) [H] real, dimension(:), intent(in) :: u !< cell averages (size N) in arbitrary units [A] @@ -66,6 +67,8 @@ subroutine P3M_limiter( N, h, u, ppoly_E, ppoly_S, ppoly_coef, h_neglect ) real, dimension(:,:), intent(inout) :: ppoly_coef !< Coefficients of polynomial [A] real, optional, intent(in) :: h_neglect !< A negligibly small width for !! the purpose of cell reconstructions [H] + logical, optional, intent(in) :: answers_2018 !< If true use older, less acccurate expressions. + ! Local variables integer :: k ! loop index logical :: monotonic ! boolean indicating whether the cubic is monotonic @@ -83,7 +86,7 @@ subroutine P3M_limiter( N, h, u, ppoly_E, ppoly_S, ppoly_coef, h_neglect ) eps = 1e-10 ! 1. Bound edge values (boundary cells are assumed to be local extrema) - call bound_edge_values( N, h, u, ppoly_E, hNeglect ) + call bound_edge_values( N, h, u, ppoly_E, hNeglect, answers_2018 ) ! 2. Systematically average discontinuous edge values call average_discontinuous_edge_values( N, ppoly_E ) diff --git a/src/ALE/PPM_functions.F90 b/src/ALE/PPM_functions.F90 index 11dabad684..6d50703975 100644 --- a/src/ALE/PPM_functions.F90 +++ b/src/ALE/PPM_functions.F90 @@ -25,22 +25,21 @@ module PPM_functions contains !> Builds quadratic polynomials coefficients from cell mean and edge values. -subroutine PPM_reconstruction( N, h, u, ppoly_E, ppoly_coef, h_neglect) +subroutine PPM_reconstruction( N, h, u, ppoly_E, ppoly_coef, h_neglect, answers_2018) 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, - !! 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. + real, dimension(N), intent(in) :: h !< Cell widths [H] + real, dimension(N), intent(in) :: u !< Cell averages [A] + real, dimension(N,2), intent(inout) :: ppoly_E !< Edge values [A] + real, dimension(N,3), intent(inout) :: ppoly_coef !< Polynomial coefficients, mainly [A] + real, optional, intent(in) :: h_neglect !< A negligibly small width [H] + logical, optional, intent(in) :: answers_2018 !< If true use older, less acccurate expressions. + ! Local variables integer :: k ! Loop index real :: edge_l, edge_r ! Edge values (left and right) ! PPM limiter - call PPM_limiter_standard( N, h, u, ppoly_E, h_neglect ) + call PPM_limiter_standard( N, h, u, ppoly_E, h_neglect, answers_2018 ) ! Loop over all cells do k = 1,N @@ -60,14 +59,14 @@ end subroutine PPM_reconstruction !> Adjusts edge values using the standard PPM limiter (Colella & Woodward, JCP 1984) !! after first checking that the edge values are bounded by neighbors cell averages !! and that the edge values are monotonic between cell averages. -subroutine PPM_limiter_standard( N, h, u, ppoly_E, h_neglect ) +subroutine PPM_limiter_standard( N, h, u, ppoly_E, h_neglect, answers_2018 ) 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) :: ppoly_E !< 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. + real, dimension(:), intent(in) :: h !< cell widths (size N) [H] + real, dimension(:), intent(in) :: u !< cell average properties (size N) [A] + real, dimension(:,:), intent(inout) :: ppoly_E !< Potentially modified edge values [A] + real, optional, intent(in) :: h_neglect !< A negligibly small width [H] + logical, optional, intent(in) :: answers_2018 !< If true use older, less acccurate expressions. + ! Local variables integer :: k ! Loop index real :: u_l, u_c, u_r ! Cell averages (left, center and right) @@ -75,7 +74,7 @@ subroutine PPM_limiter_standard( N, h, u, ppoly_E, h_neglect ) real :: expr1, expr2 ! Bound edge values - call bound_edge_values( N, h, u, ppoly_E, h_neglect ) + call bound_edge_values( N, h, u, ppoly_E, h_neglect, answers_2018 ) ! Make discontinuous edge values monotonic call check_discontinuous_edge_values( N, u, ppoly_E ) @@ -111,6 +110,7 @@ subroutine PPM_limiter_standard( N, h, u, ppoly_E, h_neglect ) endif ! This checks that the difference in edge values is representable ! and avoids overshoot problems due to round off. + !### The 1.e-60 needs to have units of [A], so this dimensionally inconsisent. if ( abs( edge_r - edge_l ) Compute ih4 edge slopes (implicit third order accurate) +!> Compute ih3 edge slopes (implicit third order accurate) !! in the same units as h. !! !! Compute edge slopes based on third-order implicit estimates. Note that @@ -48,17 +49,21 @@ module regrid_edge_slopes !! boundary conditions close the system. subroutine edge_slopes_implicit_h3( N, h, u, edge_slopes, h_neglect, answers_2018 ) integer, intent(in) :: N !< Number of cells - real, dimension(:), intent(in) :: h !< cell widths (size N) [H] - real, dimension(:), intent(in) :: u !< cell average properties (size N) in arbitrary units [A] - real, dimension(:,:), intent(inout) :: edge_slopes !< Returned edge slopes [A H-1] - real, optional, intent(in) :: h_neglect !< A negligibly small width + real, dimension(N), intent(in) :: h !< cell widths [H] + real, dimension(N), intent(in) :: u !< cell average properties in arbitrary units [A] + real, dimension(N,2), intent(inout) :: edge_slopes !< Returned edge slopes [A H-1]; the + !! second index is for the two edges of each cell. + real, optional, intent(in) :: h_neglect !< A negligibly small width [H] logical, optional, intent(in) :: answers_2018 !< If true use older, less acccurate expressions. ! Local variables integer :: i, j ! loop indexes - real :: h0, h1 ! cell widths [H] - real :: h0_2, h1_2, h0h1 ! products of cell widths [H2] - real :: h0_3, h1_3 ! products of three cell widths [H3] - real :: d ! A demporary variable [H3] + real :: h0, h1 ! cell widths [H or nondim] + real :: h0_2, h1_2, h0h1 ! products of cell widths [H2 or nondim] + real :: h0_3, h1_3 ! products of three cell widths [H3 or nondim] + real :: h_min ! A minimal cell width [H] + real :: d ! A temporary variable [H3] + real :: I_d ! A temporary variable [nondim] + real :: I_h, I_hshear ! Inverses of thicknesses [H-1] real :: alpha, beta ! stencil coefficients [nondim] real :: a, b ! weights of cells [H-1] real, parameter :: C1_12 = 1.0 / 12.0 @@ -67,11 +72,12 @@ subroutine edge_slopes_implicit_h3( N, h, u, edge_slopes, h_neglect, answers_201 real, dimension(4,4) :: Asys ! matrix used to find boundary conditions real, dimension(4) :: Bsys, Csys real, dimension(3) :: Dsys - real, dimension(N+1) :: tri_l, & ! trid. system (lower diagonal) [nondim] - tri_d, & ! trid. system (middle diagonal) [nondim] - tri_u, & ! trid. system (upper diagonal) [nondim] - tri_b, & ! trid. system (unknowns vector) [A H-1] - tri_x ! trid. system (rhs) [A H-1] + real, dimension(N+1) :: tri_l, & ! tridiagonal system (lower diagonal) [nondim] + tri_d, & ! tridiagonal system (middle diagonal) [nondim] + tri_c, & ! tridiagonal system central value, with tri_d = tri_c+tri_l+tri_u + tri_u, & ! tridiagonal system (upper diagonal) [nondim] + tri_b, & ! tridiagonal system (right hand side) [A H-1] + tri_x ! tridiagonal system (solution vector) [A H-1] real :: hNeglect ! A negligible thickness [H]. real :: hNeglect3 ! hNeglect^3 [H3]. logical :: use_2018_answers ! If true use older, less acccurate expressions. @@ -83,98 +89,150 @@ subroutine edge_slopes_implicit_h3( N, h, u, edge_slopes, h_neglect, answers_201 ! Loop on cells (except last one) do i = 1,N-1 - ! Get cell widths - h0 = h(i) - h1 = h(i+1) - - ! Auxiliary calculations - h0h1 = h0 * h1 - h0_2 = h0 * h0 - h1_2 = h1 * h1 - h0_3 = h0_2 * h0 - h1_3 = h1_2 * h1 - - d = 4.0 * h0h1 * ( h0 + h1 ) + h1_3 + h0_3 - - ! Coefficients - alpha = h1 * (h0_2 + h0h1 - h1_2) / ( d + hNeglect3 ) - beta = h0 * (h1_2 + h0h1 - h0_2) / ( d + hNeglect3 ) - a = -12.0 * h0h1 / ( d + hNeglect3 ) - b = -a - - tri_l(i+1) = alpha - tri_d(i+1) = 1.0 - tri_u(i+1) = beta - - tri_b(i+1) = a * u(i) + b * u(i+1) + if (use_2018_answers) then + ! Get cell widths + h0 = h(i) + h1 = h(i+1) + + ! Auxiliary calculations + h0h1 = h0 * h1 + h0_2 = h0 * h0 + h1_2 = h1 * h1 + h0_3 = h0_2 * h0 + h1_3 = h1_2 * h1 + + d = 4.0 * h0h1 * ( h0 + h1 ) + h1_3 + h0_3 + + ! Coefficients + alpha = h1 * (h0_2 + h0h1 - h1_2) / ( d + hNeglect3 ) + beta = h0 * (h1_2 + h0h1 - h0_2) / ( d + hNeglect3 ) + a = -12.0 * h0h1 / ( d + hNeglect3 ) + b = -a + + tri_l(i+1) = alpha + tri_d(i+1) = 1.0 + tri_u(i+1) = beta + + tri_b(i+1) = a * u(i) + b * u(i+1) + else + ! Get cell widths + h0 = h(i) + h1 = h(i+1) + + if (h0+h1 == 0.) then + ! Avoid singularities when h0+h1=0 by using values for equally spaced layers and no source term. + tri_l(i+1) = 0.1 + ! tri_d(i+1) = 1.0 + tri_c(i+1) = 0.8 + tri_u(i+1) = 0.1 + tri_b(i+1) = 0.0 + else + ! Auxiliary calculations + I_hshear = 1.0 / (h0 + h1 + hNeglect) + I_h = 1.0 / (h0 + h1) + h0 = h0 * I_h ; h1 = h1 * I_h + + h0h1 = h0 * h1 ; h0_2 = h0 * h0 ; h1_2 = h1 * h1 + h0_3 = h0_2 * h0 ; h1_3 = h1_2 * h1 + + I_d = 1.0 / (4.0 * h0h1 * ( h0 + h1 ) + h1_3 + h0_3) ! = 1 / ((h0 + h1)**3 + (h0 + h1)) + + ! Set the tridiagonal coefficients + tri_l(i+1) = (h1 * ((h0_2 + h0h1) - h1_2)) * I_d + ! tri_d(i+1) = 1.0 + tri_c(i+1) = 2.0 * ((h0_2 + h1_2) * (h0 + h1)) * I_d + tri_u(i+1) = (h0 * ((h1_2 + h0h1) - h0_2)) * I_d + + tri_b(i+1) = 12.0 * (h0h1 * I_d) * ((u(i+1) - u(i)) * I_hshear) + endif + endif 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) - enddo - - do i = 1,4 - dx = h(i) - if (use_2018_answers) then + ! Boundary conditions: set the first edge slope + if (use_2018_answers) then + x(1) = 0.0 + do i = 1,4 + dx = h(i) + x(i+1) = x(i) + dx do j = 1,4 ; Asys(i,j) = ( (x(i+1)**j) - (x(i)**j) ) / j ; enddo - else ! Use expressions with less sensitivity to roundoff - xavg = 0.5 * (x(i+1) + x(i)) + Bsys(i) = u(i) * dx + enddo + + call solve_linear_system( Asys, Bsys, Csys, 4 ) + + Dsys(1) = Csys(2) ; Dsys(2) = 2.0 * Csys(3) ; Dsys(3) = 3.0 * Csys(4) + tri_b(1) = evaluation_polynomial( Dsys, 3, x(1) ) ! Set the first edge slope + tri_d(1) = 1.0 + else ! Use expressions with less sensitivity to roundoff + h_min = max( hNeglect, hMinFrac * ((h(1) + h(2)) + (h(3) + h(4))) ) + x(1) = 0.0 + do i = 1,4 + dx = max(h_min, h(i) ) + x(i+1) = x(i) + dx + xavg = x(i) + 0.5*dx Asys(i,1) = dx Asys(i,2) = dx * xavg Asys(i,3) = dx * (xavg**2 + C1_12*dx**2) Asys(i,4) = dx * xavg * (xavg**2 + 0.25*dx**2) - endif - - Bsys(i) = u(i) * dx - - enddo - - call solve_linear_system( Asys, Bsys, Csys, 4 ) - - Dsys(1) = Csys(2) - Dsys(2) = 2.0 * Csys(3) - Dsys(3) = 3.0 * Csys(4) - - tri_d(1) = 1.0 - tri_u(1) = 0.0 - tri_b(1) = evaluation_polynomial( Dsys, 3, x(1) ) ! first edge slope - - ! Boundary conditions: right boundary - x(1) = 0.0 - do i = 2,5 - x(i) = x(i-1) + h(N-5+i) - enddo - - do i = 1,4 - dx = h(N-4+i) - if (use_2018_answers) then + Bsys(i) = u(i) * dx + enddo + + call solve_linear_system( Asys, Bsys, Csys, 4 ) + + ! Set the first edge slope + tri_b(1) = Csys(2) ! + x(1)*(2.0*Csys(3) + x(1)*(3.0*Csys(4))) + tri_c(1) = 1.0 + endif + tri_u(1) = 0.0 ! tri_l(1) = 0.0 + + ! Boundary conditions: set the last edge slope + if (use_2018_answers) then + x(1) = 0.0 + do i = 1,4 + dx = h(N-4+i) + x(i+1) = x(i) + dx do j = 1,4 ; Asys(i,j) = ( (x(i+1)**j) - (x(i)**j) ) / j ; enddo - else ! Use expressions with less sensitivity to roundoff - xavg = 0.5 * (x(i+1) + x(i)) + Bsys(i) = u(N-4+i) * dx + enddo + + call solve_linear_system( Asys, Bsys, Csys, 4 ) + + Dsys(1) = Csys(2) ; Dsys(2) = 2.0 * Csys(3) ; Dsys(3) = 3.0 * Csys(4) + ! Set the last edge slope + tri_b(N+1) = evaluation_polynomial( Dsys, 3, x(5) ) + tri_d(N+1) = 1.0 + else + ! Use expressions with less sensitivity to roundoff, including using a coordinate + ! system that sets the origin at the last interface in the domain. + h_min = max( hNeglect, hMinFrac * ((h(N-3) + h(N-2)) + (h(N-1) + h(N))) ) + x(1) = 0.0 + do i = 1,4 + dx = max(h_min, h(N+1-i) ) + x(i+1) = x(i) + dx + xavg = x(i) + 0.5*dx Asys(i,1) = dx Asys(i,2) = dx * xavg Asys(i,3) = dx * (xavg**2 + C1_12*dx**2) Asys(i,4) = dx * xavg * (xavg**2 + 0.25*dx**2) - endif - Bsys(i) = u(N-4+i) * dx - - enddo - call solve_linear_system( Asys, Bsys, Csys, 4 ) + Bsys(i) = u(N+1-i) * dx + enddo - Dsys(1) = Csys(2) - Dsys(2) = 2.0 * Csys(3) - Dsys(3) = 3.0 * Csys(4) + call solve_linear_system( Asys, Bsys, Csys, 4 ) - tri_l(N+1) = 0.0 - tri_d(N+1) = 1.0 - tri_b(N+1) = evaluation_polynomial( Dsys, 3, x(5) ) ! last edge slope + ! Set the last edge slope + tri_b(N+1) = Csys(2) + tri_c(N+1) = 1.0 + endif + tri_l(N+1) = 0.0 ! tri_u(N+1) = 0.0 - ! Solve tridiagonal system and assign edge values - call solve_tridiagonal_system( tri_l, tri_d, tri_u, tri_b, tri_x, N+1 ) + ! Solve tridiagonal system and assign edge slopes + if (use_2018_answers) then + call solve_tridiagonal_system( tri_l, tri_d, tri_u, tri_b, tri_x, N+1 ) + else + call solve_diag_dominant_tridiag( tri_l, tri_c, tri_u, tri_b, tri_x, N+1 ) + endif do i = 2,N edge_slopes(i,1) = tri_x(i) @@ -190,9 +248,10 @@ 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, answers_2018 ) integer, intent(in) :: N !< Number of cells - real, dimension(:), intent(in) :: h !< cell widths (size N) [H] - real, dimension(:), intent(in) :: u !< cell average properties (size N) in arbitrary units [A] - real, dimension(:,:), intent(inout) :: edge_slopes !< Returned edge slopes [A H-1] + real, dimension(N), intent(in) :: h !< cell widths [H] + real, dimension(N), intent(in) :: u !< cell average properties in arbitrary units [A] + real, dimension(N,2), intent(inout) :: edge_slopes !< Returned edge slopes [A H-1]; the + !! second index is for the two edges of each cell. real, optional, intent(in) :: h_neglect !< A negligibly small width [H] logical, optional, intent(in) :: answers_2018 !< If true use older, less acccurate expressions. ! ----------------------------------------------------------------------------- @@ -264,7 +323,7 @@ subroutine edge_slopes_implicit_h5( N, h, u, edge_slopes, h_neglect, answers_201 hNeglect = hNeglect_dflt ; if (present(h_neglect)) hNeglect = h_neglect use_2018_answers = .true. ; if (present(answers_2018)) use_2018_answers = answers_2018 - ! Loop on cells (except last one) + ! Loop on cells (except the first and last ones) do k = 2,N-2 ! Cell widths diff --git a/src/ALE/regrid_edge_values.F90 b/src/ALE/regrid_edge_values.F90 index f82e42e0e6..7dbea4b62b 100644 --- a/src/ALE/regrid_edge_values.F90 +++ b/src/ALE/regrid_edge_values.F90 @@ -3,7 +3,7 @@ module regrid_edge_values ! This file is part of MOM6. See LICENSE.md for the license. -use regrid_solvers, only : solve_linear_system, solve_tridiagonal_system +use regrid_solvers, only : solve_linear_system, solve_tridiagonal_system, solve_diag_dominant_tridiag use polynomial_functions, only : evaluation_polynomial implicit none ; private @@ -19,8 +19,6 @@ module regrid_edge_values public edge_values_implicit_h4 public edge_values_implicit_h6 -#undef __DO_SAFETY_CHECKS__ - ! The following parameters are used to avoid singular matrices for boundary ! extrapolation. The are needed only in the case where thicknesses vanish ! to a small enough values such that the eigenvalues of the matrix can not @@ -44,90 +42,68 @@ module regrid_edge_values !! Both boundary edge values are set equal to the boundary cell averages. !! Any extrapolation scheme is applied after this routine has been called. !! Therefore, boundary cells are treated as if they were local extrama. -subroutine bound_edge_values( N, h, u, edge_val, h_neglect ) +subroutine bound_edge_values( N, h, u, edge_val, h_neglect, answers_2018 ) integer, intent(in) :: N !< Number of cells - real, dimension(:), intent(in) :: h !< cell widths (size N) [H] - real, dimension(:), intent(in) :: u !< cell average properties (size N) in arbitrary units [A] - real, dimension(:,:), intent(inout) :: edge_val !< Potentially modified edge values [A] + real, dimension(N), intent(in) :: h !< cell widths [H] + real, dimension(N), intent(in) :: u !< cell average properties in arbitrary units [A] + real, dimension(N,2), intent(inout) :: edge_val !< Potentially modified edge values [A]; the + !! second index is for the two edges of each cell. real, optional, intent(in) :: h_neglect !< A negligibly small width [H] + logical, optional, intent(in) :: answers_2018 !< If true use older, less acccurate expressions. ! Local variables - integer :: k ! loop index - integer :: k0, k1, k2 - real :: h_l, h_c, h_r ! Layer thicknesses [H] - real :: u_l, u_c, u_r ! Cell average properties [A] - real :: u0_l, u0_r ! Edge values of properties [A] - real :: sigma_l, sigma_c, sigma_r ! left, center and right - ! van Leer slopes [A H-1] - real :: slope ! retained PLM slope [A H-1] - real :: hNeglect ! A negligible thickness [H]. + real :: sigma_l, sigma_c, sigma_r ! left, center and right van Leer slopes [A H-1] or [A] + real :: slope_x_h ! retained PLM slope times half grid step [A] + real :: hNeglect ! A negligible thickness [H]. + logical :: use_2018_answers ! If true use older, less acccurate expressions. + integer :: k, km1, kp1 ! Loop index and the values to either side. - hNeglect = hNeglect_dflt ; if (present(h_neglect)) hNeglect = h_neglect + use_2018_answers = .true. ; if (present(answers_2018)) use_2018_answers = answers_2018 + if (use_2018_answers) then + hNeglect = hNeglect_dflt ; if (present(h_neglect)) hNeglect = h_neglect + endif ! Loop on cells to bound edge value do k = 1,N - ! For the sake of bounding boundary edge values, the left neighbor - ! of the left boundary cell is assumed to be the same as the left - ! 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 == 1 ) then - k0 = 1 - k1 = 1 - k2 = 2 - elseif ( k == N ) then - k0 = N-1 - k1 = N - k2 = N - else - k0 = k-1 - k1 = k - k2 = k+1 - endif - - ! All cells can now be treated equally - h_l = h(k0) - h_c = h(k1) - h_r = h(k2) - - u_l = u(k0) - u_c = u(k1) - u_r = u(k2) - - u0_l = edge_val(k,1) - u0_r = edge_val(k,2) + ! For the sake of bounding boundary edge values, the left neighbor of the left boundary cell + ! is assumed to be the same as the left 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. + km1 = max(1,k-1) ; kp1 = min(k+1,N) - 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) > 0.0 ) then - slope = sign( min(abs(sigma_l),abs(sigma_c),abs(sigma_r)), sigma_c ) - else - slope = 0.0 + slope_x_h = 0.0 + if (use_2018_answers) then + sigma_l = 2.0 * ( u(k) - u(km1) ) / ( h(k) + hNeglect ) + sigma_c = 2.0 * ( u(kp1) - u(km1) ) / ( h(km1) + 2.0*h(k) + h(kp1) + hNeglect ) + sigma_r = 2.0 * ( u(kp1) - u(k) ) / ( h(k) + hNeglect ) + + ! The limiter is used in the local coordinate system to each cell, so for convenience store + ! the slope times a half grid spacing. (See White and Adcroft JCP 2008 Eqs 19 and 20) + if ( (sigma_l * sigma_r) > 0.0 ) & + slope_x_h = 0.5 * h(k) * sign( min(abs(sigma_l),abs(sigma_c),abs(sigma_r)), sigma_c ) + elseif ( ((h(km1) + h(kp1)) + 2.0*h(k)) > 0.0 ) then + sigma_l = ( u(k) - u(km1) ) + sigma_c = ( u(kp1) - u(km1) ) * ( h(k) / ((h(km1) + h(kp1)) + 2.0*h(k)) ) + sigma_r = ( u(kp1) - u(k) ) + + ! The limiter is used in the local coordinate system to each cell, so for convenience store + ! the slope times a half grid spacing. (See White and Adcroft JCP 2008 Eqs 19 and 20) + if ( (sigma_l * sigma_r) > 0.0 ) & + slope_x_h = sign( min(abs(sigma_l),abs(sigma_c),abs(sigma_r)), sigma_c ) 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 - ! simply a way to make it useable in the limiter (cfr White and Adcroft - ! JCP 2008 Eqs 19 and 20) - slope = slope * h_c * 0.5 - - 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 ) + ! Limit the edge values + if ( (u(km1)-edge_val(k,1)) * (edge_val(k,1)-u(k)) < 0.0 ) then + edge_val(k,1) = u(k) - sign( min( abs(slope_x_h), abs(edge_val(k,1)-u(k)) ), slope_x_h ) endif - 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 ) + if ( (u(kp1)-edge_val(k,2)) * (edge_val(k,2)-u(k)) < 0.0 ) then + edge_val(k,2) = u(k) + sign( min( abs(slope_x_h), abs(edge_val(k,2)-u(k)) ), slope_x_h ) 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_val(k,1) = u0_l - edge_val(k,2) = u0_r + ! Finally bound by neighboring cell means in case of roundoff + edge_val(k,1) = max( min( edge_val(k,1), max(u(km1), u(k)) ), min(u(km1), u(k)) ) + edge_val(k,2) = max( min( edge_val(k,2), max(u(kp1), u(k)) ), min(u(kp1), u(k)) ) enddo ! loop on interior edges @@ -139,25 +115,17 @@ end subroutine bound_edge_values !! If so, compute the average and replace the edge values by the 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. + real, dimension(N,2), intent(inout) :: edge_val !< Edge values that may be modified [A]; the + !! second index is for the two edges of each cell. ! Local variables integer :: k ! loop index - real :: u0_minus ! left value at given edge - real :: u0_plus ! right value at given edge real :: u0_avg ! avg value at given edge ! Loop on interior edges do k = 1,N-1 - - ! Edge value on the left of the edge - u0_minus = edge_val(k,2) - - ! Edge value on the right of the edge - u0_plus = edge_val(k+1,1) - - if ( u0_minus /= u0_plus ) then - u0_avg = 0.5 * ( u0_minus + u0_plus ) + ! Compare edge values on the right and left sides of the edge + if ( edge_val(k,2) /= edge_val(k+1,1) ) then + u0_avg = 0.5 * ( edge_val(k,2) + edge_val(k+1,1) ) edge_val(k,2) = u0_avg edge_val(k+1,1) = u0_avg endif @@ -172,38 +140,20 @@ end subroutine average_discontinuous_edge_values !! If so and if they are not monotonic, replace each edge value by their average. 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) in arbitrary units [A] - real, dimension(:,:), intent(inout) :: edge_val !< Cell edge values [A]. + real, dimension(N), intent(in) :: u !< cell averages in arbitrary units [A] + real, dimension(N,2), intent(inout) :: edge_val !< Cell edge values [A]; the + !! second index is for the two edges of each cell. ! Local variables integer :: k ! loop index - real :: u0_minus ! left value at given edge [A] - real :: u0_plus ! right value at given edge [A] - real :: um_minus ! left cell average [A] - real :: um_plus ! right cell average [A] real :: u0_avg ! avg value at given edge [A] - ! Loop on interior cells do k = 1,N-1 - - ! Edge value on the left of the edge - u0_minus = edge_val(k,2) - - ! Edge value on the right of the edge - u0_plus = edge_val(k+1,1) - - ! Left cell average - um_minus = u(k) - - ! Right cell average - um_plus = u(k+1) - - 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) ) + if ( (edge_val(k+1,1) - edge_val(k,2)) * (u(k+1) - u(k)) < 0.0 ) then + u0_avg = 0.5 * ( edge_val(k,2) + edge_val(k+1,1) ) + u0_avg = max( min( u0_avg, max(u(k), u(k+1)) ), min(u(k), u(k+1)) ) edge_val(k,2) = u0_avg edge_val(k+1,1) = u0_avg endif - enddo ! end loop on interior edges end subroutine check_discontinuous_edge_values @@ -222,47 +172,31 @@ end subroutine check_discontinuous_edge_values !! k-1/2 !! !! Boundary edge values are set to be equal to the boundary cell averages. -subroutine edge_values_explicit_h2( N, h, u, edge_val, h_neglect ) +subroutine edge_values_explicit_h2( N, h, u, edge_val ) integer, intent(in) :: N !< Number of cells - real, dimension(:), intent(in) :: h !< cell widths (size N) [H] - real, dimension(:), intent(in) :: u !< cell average properties (size N) in arbitrary units [A] - real, dimension(:,:), intent(inout) :: edge_val !< Returned edge values [A]; the second index size is 2. - real, optional, intent(in) :: h_neglect !< A negligibly small width [H] + real, dimension(N), intent(in) :: h !< cell widths [H] + real, dimension(N), intent(in) :: u !< cell average properties in arbitrary units [A] + real, dimension(N,2), intent(inout) :: edge_val !< Returned edge values [A]; the + !! second index is for the two edges of each cell. + ! Local variables integer :: k ! loop index - real :: h0, h1 ! cell widths [H] - real :: u0, u1 ! cell averages [A] - real :: hNeglect ! A negligible thickness [H] - hNeglect = hNeglect_edge_dflt ; if (present(h_neglect)) hNeglect = h_neglect + ! Boundary edge values are simply equal to the boundary cell averages + edge_val(1,1) = u(1) + edge_val(N,2) = u(N) - ! Loop on interior cells do k = 2,N - - h0 = h(k-1) - h1 = h(k) - - ! Avoid singularities when h0+h1=0 - if (h0+h1==0.) then - h0 = hNeglect - h1 = hNeglect - endif - - u0 = u(k-1) - u1 = u(k) - ! Compute left edge value - edge_val(k,1) = ( u0*h1 + u1*h0 ) / ( h0 + h1 ) + if (h(k-1) + h(k) == 0.0) then ! Avoid singularities when h0+h1=0 + edge_val(k,1) = 0.5 * (u(k-1) + u(k)) + else + edge_val(k,1) = ( u(k-1)*h(k) + u(k)*h(k-1) ) / ( h(k-1) + h(k) ) + endif - ! Left edge value of the current cell is equal to right edge - ! value of left cell + ! Left edge value of the current cell is equal to right edge value of left cell edge_val(k-1,2) = edge_val(k,1) - - enddo ! end loop on interior cells - - ! Boundary edge values are simply equal to the boundary cell averages - edge_val(1,1) = u(1) - edge_val(N,2) = u(N) + enddo end subroutine edge_values_explicit_h2 @@ -287,18 +221,20 @@ end subroutine edge_values_explicit_h2 !! For this fourth-order scheme, at least four cells must exist. subroutine edge_values_explicit_h4( N, h, u, edge_val, h_neglect, answers_2018 ) integer, intent(in) :: N !< Number of cells - real, dimension(:), intent(in) :: h !< cell widths (size N) [H] - real, dimension(:), intent(in) :: u !< cell average properties (size N) in arbitrary units [A] - real, dimension(:,:), intent(inout) :: edge_val !< Returned edge values [A]; the second index size is 2. + real, dimension(N), intent(in) :: h !< cell widths [H] + real, dimension(N), intent(in) :: u !< cell average properties in arbitrary units [A] + real, dimension(N,2), intent(inout) :: edge_val !< Returned edge values [A]; the second index + !! is for the two edges of each cell. real, optional, intent(in) :: h_neglect !< A negligibly small width [H] logical, optional, intent(in) :: answers_2018 !< If true use older, less acccurate expressions. ! Local variables integer :: i, j - real :: u0, u1, u2, u3 ! temporary properties [A] real :: h0, h1, h2, h3 ! temporary thicknesses [H] + real :: h_sum ! A sum of adjacent thicknesses [H] + real :: h_min ! A minimal cell width [H] real :: f1, f2, f3 ! auxiliary variables with various units - real :: e ! edge value + real :: et1, et2, et3 ! terms the expresson for edge values [A H] real, dimension(5) :: x ! Coordinate system with 0 at edges [H] real, parameter :: C1_12 = 1.0 / 12.0 real :: dx, xavg ! Differences and averages of successive values of x [same units as h] @@ -319,146 +255,128 @@ subroutine edge_values_explicit_h4( N, h, u, edge_val, h_neglect, answers_2018 ) h3 = h(i+1) ! Avoid singularities when consecutive pairs of h vanish - if (h0+h1==0. .or. h1+h2==0. .or. h2+h3==0.) then - f1 = max( hNeglect, h0+h1+h2+h3 ) - h0 = max( hMinFrac*f1, h(i-2) ) - h1 = max( hMinFrac*f1, h(i-1) ) - h2 = max( hMinFrac*f1, h(i) ) - h3 = max( hMinFrac*f1, h(i+1) ) + if (h0+h1==0.0 .or. h1+h2==0.0 .or. h2+h3==0.0) then + if (use_2018_answers) then + h_min = hMinFrac*max( hNeglect, h0+h1+h2+h3 ) + else + h_min = hMinFrac*max( hNeglect, (h0+h1)+(h2+h3) ) + endif + h0 = max( h_min, h(i-2) ) + h1 = max( h_min, h(i-1) ) + h2 = max( h_min, h(i) ) + h3 = max( h_min, h(i+1) ) endif - u0 = u(i-2) - u1 = u(i-1) - u2 = u(i) - u3 = u(i+1) - - f1 = (h0+h1) * (h2+h3) / (h1+h2) - f2 = u1 * h2 + u2 * h1 - f3 = 1.0 / (h0+h1+h2) + 1.0 / (h1+h2+h3) - - e = f1 * f2 * f3 - - f1 = h2 * (h2+h3) / ( (h0+h1+h2)*(h0+h1) ) - f2 = u1*(h0+2.0*h1) - u0*h1 - - e = e + f1*f2 - - f1 = h1 * (h0+h1) / ( (h1+h2+h3)*(h2+h3) ) - f2 = u2*(2.0*h2+h3) - u3*h2 - - e = e + f1*f2 + if (use_2018_answers) then + f1 = (h0+h1) * (h2+h3) / (h1+h2) + f2 = h2 * u(i-1) + h1 * u(i) + f3 = 1.0 / (h0+h1+h2) + 1.0 / (h1+h2+h3) + et1 = f1 * f2 * f3 + else + et1 = ( (h0+h1) * (h2+h3) * ((h1+h2+h3) + (h0+h1+h2)) / & + (((h1+h2) * ((h0+h1+h2) * (h1+h2+h3)))) ) * & + (h2 * u(i-1) + h1 * u(i)) + endif - e = e / ( h0 + h1 + h2 + h3) + et2 = ( h2 * (h2+h3) / ( (h0+h1+h2)*(h0+h1) ) ) * & + ((h0+2.0*h1) * u(i-1) - h1 * u(i-2)) - edge_val(i,1) = e - edge_val(i-1,2) = e + et3 = ( h1 * (h0+h1) / ( (h1+h2+h3)*(h2+h3) ) ) * & + ((2.0*h2+h3) * u(i) - h2 * u(i+1)) -#ifdef __DO_SAFETY_CHECKS__ - if (e /= e) then - write(0,*) 'NaN in explicit_edge_h4 at k=',i - write(0,*) 'u0-u3=',u0,u1,u2,u3 - write(0,*) 'h0-h3=',h0,h1,h2,h3 - write(0,*) 'f1-f3=',f1,f2,f3 - stop 'Nan during edge_values_explicit_h4' + if (use_2018_answers) then + edge_val(i,1) = (et1 + et2 + et3) / ( h0 + h1 + h2 + h3) + else + edge_val(i,1) = (et1 + (et2 + et3)) / ((h0 + h1) + (h2 + h3)) endif -#endif + edge_val(i-1,2) = edge_val(i,1) 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)) - enddo - - do i = 1,4 - dx = max(f1, h(i) ) - if (use_2018_answers) then + if (use_2018_answers) then + h_min = max( hNeglect, hMinFrac*sum(h(1:4)) ) + x(1) = 0.0 + do i = 1,4 + dx = max(h_min, h(i) ) + x(i+1) = x(i) + dx do j = 1,4 ; A(i,j) = ( (x(i+1)**j) - (x(i)**j) ) / real(j) ; enddo - else ! Use expressions with less sensitivity to roundoff + B(i) = u(i) * dx + enddo + + call solve_linear_system( A, B, C, 4 ) + + ! Set the edge values of the first cell + edge_val(1,1) = evaluation_polynomial( C, 4, x(1) ) + edge_val(1,2) = evaluation_polynomial( C, 4, x(2) ) + else ! Use expressions with less sensitivity to roundoff + h_min = hMinFrac*((h(1) + h(2)) + (h(3) + h(4))) + if (h_min == 0.0) h_min = 1.0 ! Handle the case of all massless layers. + x(1) = 0.0 + do i = 1,4 + dx = max(h_min, h(i) ) + x(i+1) = x(i) + dx xavg = 0.5 * (x(i+1) + x(i)) A(i,1) = dx A(i,2) = dx * xavg A(i,3) = dx * (xavg**2 + C1_12*dx**2) A(i,4) = dx * xavg * (xavg**2 + 0.25*dx**2) - endif + B(i) = u(i) * dx + enddo - B(i) = u(i) * dx + call solve_linear_system( A, B, C, 4 ) - enddo + ! Set the edge values of the first cell + edge_val(1,1) = C(1) ! x(1) = 0 so ignore + x(1)*(C(2) + x(1)*(C(3) + x(1)*C(4))) + edge_val(1,2) = C(1) + x(2)*(C(2) + x(2)*(C(3) + x(2)*C(4))) + endif + edge_val(2,1) = edge_val(1,2) - call solve_linear_system( A, B, C, 4 ) + ! Determine two edge values of the last cell + if (use_2018_answers) then + h_min = max( hNeglect, hMinFrac*sum(h(N-3:N)) ) - ! First edge value - edge_val(1,1) = evaluation_polynomial( C, 4, x(1) ) + x(1) = 0.0 + do i = 1,4 + dx = max(h_min, h(N-4+i) ) + x(i+1) = x(i) + dx + do j = 1,4 ; A(i,j) = ( (x(i+1)**j) - (x(i)**j) ) / real(j) ; enddo + B(i) = u(N-4+i) * dx + enddo - ! Second edge value - edge_val(1,2) = evaluation_polynomial( C, 4, x(2) ) - edge_val(2,1) = edge_val(1,2) + call solve_linear_system( A, B, C, 4 ) -#ifdef __DO_SAFETY_CHECKS__ - 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 - write(0,*) 'C=',C - write(0,*) 'h(1:4)=',h(1:4) - write(0,*) 'x=',x - stop 'Nan during edge_values_explicit_h4' - endif -#endif + ! Set the last and second to last edge values + edge_val(N,2) = evaluation_polynomial( C, 4, x(5) ) + edge_val(N,1) = evaluation_polynomial( C, 4, x(4) ) + else + ! Use expressions with less sensitivity to roundoff, including using a coordinate + ! system that sets the origin at the last interface in the domain. + h_min = hMinFrac * ((h(N-3) + h(N-2)) + (h(N-1) + h(N))) + if (h_min == 0.0) h_min = 1.0 ! Handle the case of all massless layers. - ! Determine last two edge values - f1 = max( hNeglect, hMinFrac*sum(h(N-3:N)) ) - x(1) = 0.0 - do i = 2,5 - x(i) = x(i-1) + max(f1, h(N-5+i)) - enddo + x(1) = 0.0 + + do i=1,4 + dx = max(h_min, h(N+1-i) ) + x(i+1) = x(i) + dx + xavg = x(i) + 0.5*dx - do i = 1,4 - dx = max(f1, h(N-4+i) ) - if (use_2018_answers) then - do j = 1,4 ; A(i,j) = ( (x(i+1)**j) - (x(i)**j) ) / real(j) ; enddo - else ! Use expressions with less sensitivity to roundoff - xavg = 0.5 * (x(i+1) + x(i)) A(i,1) = dx A(i,2) = dx * xavg A(i,3) = dx * (xavg**2 + C1_12*dx**2) A(i,4) = dx * xavg * (xavg**2 + 0.25*dx**2) - endif - B(i) = u(N-4+i) * dx - - enddo - - call solve_linear_system( A, B, C, 4 ) - - ! Last edge value - edge_val(N,2) = evaluation_polynomial( C, 4, x(5) ) + B(i) = u(N+1-i) * dx + enddo - ! Second to last edge value - edge_val(N,1) = evaluation_polynomial( C, 4, x(4) ) - edge_val(N-1,2) = edge_val(N,1) + call solve_linear_system( A, B, C, 4 ) -#ifdef __DO_SAFETY_CHECKS__ - 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) - enddo - write(0,*) A(i,:) - B(i) = u(N-4+i) * ( h(N-4+i) ) - enddo - write(0,*) 'B=',B - write(0,*) 'C=',C - write(0,*) 'h(:N)=',h(N-3:N) - write(0,*) 'x=',x - stop 'Nan during edge_values_explicit_h4' + ! Set the last and second to last edge values + edge_val(N,2) = C(1) + edge_val(N,1) = C(1) + x(2)*(C(2) + x(2)*(C(3) + x(2)*C(4))) endif -#endif + edge_val(N-1,2) = edge_val(N,1) end subroutine edge_values_explicit_h4 @@ -490,29 +408,34 @@ end subroutine edge_values_explicit_h4 !! boundary conditions close the system. subroutine edge_values_implicit_h4( N, h, u, edge_val, h_neglect, answers_2018 ) integer, intent(in) :: N !< Number of cells - real, dimension(:), intent(in) :: h !< cell widths (size N) [H] - real, dimension(:), intent(in) :: u !< cell average properties (size N) in arbitrary units [A] - real, dimension(:,:), intent(inout) :: edge_val !< Returned edge values [A]; the second index size is 2. + real, dimension(N), intent(in) :: h !< cell widths [H] + real, dimension(N), intent(in) :: u !< cell average properties in arbitrary units [A] + real, dimension(N,2), intent(inout) :: edge_val !< Returned edge values [A]; the second index + !! is for the two edges of each cell. real, optional, intent(in) :: h_neglect !< A negligibly small width [H] logical, optional, intent(in) :: answers_2018 !< If true use older, less acccurate expressions. ! Local variables integer :: i, j ! loop indexes real :: h0, h1 ! cell widths [H] + real :: h_min ! A minimal cell width [H] + real :: h_sum ! A sum of adjacent thicknesses [H] real :: h0_2, h1_2, h0h1 real :: d2, d4 - real :: alpha, beta ! stencil coefficients + real :: alpha, beta ! stencil coefficients [nondim] + real :: I_h2, abmix ! stencil coefficients [nondim] real :: a, b real, dimension(5) :: x ! Coordinate system with 0 at edges [H] real, parameter :: C1_12 = 1.0 / 12.0 real :: dx, xavg ! Differences and averages of successive values of x [H] real, dimension(4,4) :: Asys ! boundary conditions real, dimension(4) :: Bsys, Csys - real, dimension(N+1) :: tri_l, & ! trid. system (lower diagonal) - tri_d, & ! trid. system (middle diagonal) - tri_u, & ! trid. system (upper diagonal) - tri_b, & ! trid. system (unknowns vector) - tri_x ! trid. system (rhs) + real, dimension(N+1) :: tri_l, & ! tridiagonal system (lower diagonal) [nondim] + tri_d, & ! tridiagonal system (middle diagonal) [nondim] + tri_c, & ! tridiagonal system central value, with tri_d = tri_c+tri_l+tri_u + tri_u, & ! tridiagonal system (upper diagonal) [nondim] + tri_b, & ! tridiagonal system (right hand side) [A] + tri_x ! tridiagonal system (solution vector) [A] real :: hNeglect ! A negligible thickness [H] logical :: use_2018_answers ! If true use older, less acccurate expressions. @@ -526,98 +449,144 @@ subroutine edge_values_implicit_h4( N, h, u, edge_val, h_neglect, answers_2018 ) h0 = h(i) h1 = h(i+1) - ! Avoid singularities when h0+h1=0 - if (h0+h1==0.) then - h0 = hNeglect - h1 = hNeglect + if (use_2018_answers) then + ! Avoid singularities when h0+h1=0 + if (h0+h1==0.) then + h0 = hNeglect + h1 = hNeglect + endif + + ! Auxiliary calculations + d2 = (h0 + h1) ** 2 + d4 = d2 ** 2 + h0h1 = h0 * h1 + h0_2 = h0 * h0 + h1_2 = h1 * h1 + + ! Coefficients + alpha = h1_2 / d2 + beta = h0_2 / d2 + a = 2.0 * h1_2 * ( h1_2 + 2.0 * h0_2 + 3.0 * h0h1 ) / d4 + b = 2.0 * h0_2 * ( h0_2 + 2.0 * h1_2 + 3.0 * h0h1 ) / d4 + + tri_d(i+1) = 1.0 + else ! Use expressions with less sensitivity to roundoff + if (h0+h1==0.) then ! Avoid singularities when h0+h1=0 + alpha = 0.25 ; beta = 0.25 ; abmix = 0.25 + else + ! The 1e-12 here attempts to balance truncation errors from the differences of + ! large numbers against errors from approximating thin layers as non-vanishing. + if (abs(h0) < 1.0e-12*abs(h1)) h0 = 1.0e-12*h1 + if (abs(h1) < 1.0e-12*abs(h0)) h1 = 1.0e-12*h0 + I_h2 = 1.0 / ((h0 + h1)**2) + alpha = (h1 * h1) * I_h2 + beta = (h0 * h0) * I_h2 + abmix = (h0 * h1) * I_h2 + endif + a = 2.0 * alpha * ( alpha + 2.0 * beta + 3.0 * abmix ) + b = 2.0 * beta * ( beta + 2.0 * alpha + 3.0 * abmix ) + + tri_c(i+1) = 2.0*abmix ! = 1.0 - alpha - beta endif - ! Auxiliary calculations - d2 = (h0 + h1) ** 2 - d4 = d2 ** 2 - h0h1 = h0 * h1 - h0_2 = h0 * h0 - h1_2 = h1 * h1 - - ! Coefficients - alpha = h1_2 / d2 - beta = h0_2 / d2 - a = 2.0 * h1_2 * ( h1_2 + 2.0 * h0_2 + 3.0 * h0h1 ) / d4 - b = 2.0 * h0_2 * ( h0_2 + 2.0 * h1_2 + 3.0 * h0h1 ) / d4 - tri_l(i+1) = alpha - tri_d(i+1) = 1.0 tri_u(i+1) = beta tri_b(i+1) = a * u(i) + b * u(i+1) 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) ) - enddo - - do i = 1,4 - dx = max(h0, h(i) ) - if (use_2018_answers) then + ! Boundary conditions: set the first boundary value + if (use_2018_answers) then + h_min = max( hNeglect, hMinFrac*sum(h(1:4)) ) + x(1) = 0.0 + do i = 1,4 + dx = max(h_min, h(i) ) + x(i+1) = x(i) + dx do j = 1,4 ; Asys(i,j) = ( (x(i+1)**j) - (x(i)**j) ) / j ; enddo - else ! Use expressions with less sensitivity to roundoff - xavg = 0.5 * (x(i+1) + x(i)) + Bsys(i) = u(i) * dx + enddo + + call solve_linear_system( Asys, Bsys, Csys, 4 ) + + tri_b(1) = evaluation_polynomial( Csys, 4, x(1) ) ! Set the first edge value + tri_d(1) = 1.0 + else ! Use expressions with less sensitivity to roundoff + h_min = max( hNeglect, hMinFrac * ((h(1) + h(2)) + (h(3) + h(4))) ) + x(1) = 0.0 + do i = 1,4 + dx = max(h_min, h(i) ) + x(i+1) = x(i) + dx + xavg = x(i) + 0.5*dx Asys(i,1) = dx Asys(i,2) = dx * xavg Asys(i,3) = dx * (xavg**2 + C1_12*dx**2) Asys(i,4) = dx * xavg * (xavg**2 + 0.25*dx**2) - endif + Bsys(i) = u(i) * dx + enddo - Bsys(i) = u(i) * dx + call solve_linear_system( Asys, Bsys, Csys, 4 ) - enddo + tri_b(1) = Csys(1) ! Set the first edge value, using the fact that x(1) = 0. + tri_c(1) = 1.0 + endif + tri_u(1) = 0.0 ! tri_l(1) = 0.0 + + ! Boundary conditions: set the last boundary value + if (use_2018_answers) then + h_min = max( hNeglect, hMinFrac*sum(h(N-3:N)) ) + x(1) = 0.0 + do i=1,4 + dx = max(h_min, h(N-4+i) ) + x(i+1) = x(i) + dx + do j = 1,4 ; Asys(i,j) = ( (x(i+1)**j) - (x(i)**j) ) / j ; enddo + Bsys(i) = u(N-4+i) * dx + enddo - call solve_linear_system( Asys, Bsys, Csys, 4 ) + call solve_linear_system( Asys, Bsys, Csys, 4 ) - tri_d(1) = 1.0 - tri_u(1) = 0.0 - tri_b(1) = evaluation_polynomial( Csys, 4, x(1) ) ! first edge value + ! Set the last edge value + tri_b(N+1) = evaluation_polynomial( Csys, 4, x(5) ) + tri_d(N+1) = 1.0 - ! Boundary conditions: right boundary - h0 = max( hNeglect, hMinFrac*sum(h(N-3:N)) ) - x(1) = 0.0 - do i = 2,5 - x(i) = x(i-1) + max( h0, h(N-5+i) ) - enddo + else + ! Use expressions with less sensitivity to roundoff, including using a coordinate + ! system that sets the origin at the last interface in the domain. + h_min = max( hNeglect, hMinFrac * ((h(N-3) + h(N-2)) + (h(N-1) + h(N))) ) + x(1) = 0.0 + do i=1,4 + dx = max(h_min, h(N+1-i) ) + x(i+1) = x(i) + dx + xavg = x(i) + 0.5*dx - do i = 1,4 - dx = max(h0, h(N-4+i) ) - if (use_2018_answers) then - do j = 1,4 ; Asys(i,j) = ( (x(i+1)**j) - (x(i)**j) ) / j ; enddo - else ! Use expressions with less sensitivity to roundoff - xavg = 0.5 * (x(i+1) + x(i)) Asys(i,1) = dx Asys(i,2) = dx * xavg Asys(i,3) = dx * (xavg**2 + C1_12*dx**2) Asys(i,4) = dx * xavg * (xavg**2 + 0.25*dx**2) - endif - Bsys(i) = u(N-4+i) * dx - enddo + Bsys(i) = u(N+1-i) * dx + enddo - call solve_linear_system( Asys, Bsys, Csys, 4 ) + call solve_linear_system( Asys, Bsys, Csys, 4 ) - tri_l(N+1) = 0.0 - tri_d(N+1) = 1.0 - tri_b(N+1) = evaluation_polynomial( Csys, 4, x(5) ) ! last edge value + ! Set the last edge value + tri_b(N+1) = Csys(1) + tri_c(N+1) = 1.0 + endif + tri_l(N+1) = 0.0 ! tri_u(N+1) = 0.0 ! Solve tridiagonal system and assign edge values - call solve_tridiagonal_system( tri_l, tri_d, tri_u, tri_b, tri_x, N+1 ) + if (use_2018_answers) then + call solve_tridiagonal_system( tri_l, tri_d, tri_u, tri_b, tri_x, N+1 ) + else + call solve_diag_dominant_tridiag( tri_l, tri_c, tri_u, tri_b, tri_x, N+1 ) + endif - do i = 2,N + edge_val(1,1) = tri_x(1) + do i=2,N 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 @@ -659,9 +628,10 @@ end subroutine edge_values_implicit_h4 !! on nonuniform meshes turned out to be intractable. subroutine edge_values_implicit_h6( N, h, u, edge_val, h_neglect, answers_2018 ) integer, intent(in) :: N !< Number of cells - real, dimension(:), intent(in) :: h !< cell widths (size N) [H] - real, dimension(:), intent(in) :: u !< cell average properties (size N) in arbitrary units [A] - real, dimension(:,:), intent(inout) :: edge_val !< Returned edge values [A]; the second index size is 2. + real, dimension(N), intent(in) :: h !< cell widths [H] + real, dimension(N), intent(in) :: u !< cell average properties (size N) in arbitrary units [A] + real, dimension(N,2), intent(inout) :: edge_val !< Returned edge values [A]; the second index + !! is for the two edges of each cell. real, optional, intent(in) :: h_neglect !< A negligibly small width [H] logical, optional, intent(in) :: answers_2018 !< If true use older, less acccurate expressions. @@ -941,6 +911,7 @@ subroutine edge_values_implicit_h6( N, h, u, edge_val, h_neglect, answers_2018 ) tri_b(2) = a * u(1) + b * u(2) + c * u(3) + d * u(4) ! Boundary conditions: left boundary +! h_sum = (h(1) + h(2)) + (h(5) + h(6)) + (h(3) + h(4)) g = max( hNeglect, hMinFrac*sum(h(1:6)) ) x(1) = 0.0 do i = 2,7 @@ -1093,6 +1064,7 @@ subroutine edge_values_implicit_h6( N, h, u, edge_val, h_neglect, answers_2018 ) tri_b(N) = a * u(N-3) + b * u(N-2) + c * u(N-1) + d * u(N) ! Boundary conditions: right boundary +! h_sum = (h(N-3) + h(N-2)) + ((h(N-1) + h(N)) + (h(N-5) + h(N-4))) g = max( hNeglect, hMinFrac*sum(h(N-5:N)) ) x(1) = 0.0 do i = 2,7 diff --git a/src/ALE/regrid_interp.F90 b/src/ALE/regrid_interp.F90 index ace311cc21..7b6bfd0e92 100644 --- a/src/ALE/regrid_interp.F90 +++ b/src/ALE/regrid_interp.F90 @@ -77,20 +77,20 @@ module regrid_interp !! continuous linear scheme (P1M h2). subroutine regridding_set_ppolys(CS, densities, n0, h0, ppoly0_E, ppoly0_S, & ppoly0_coefs, degree, h_neglect, h_neglect_edge) - type(interp_CS_type),intent(in) :: CS !< Interpolation control structure - real, dimension(:), intent(in) :: densities !< Actual cell densities - integer, intent(in) :: n0 !< Number of cells on source grid - real, dimension(:), intent(in) :: h0 !< cell widths on source grid - real, dimension(:,:),intent(inout) :: ppoly0_E !< Edge value of polynomial - real, dimension(:,:),intent(inout) :: ppoly0_S !< Edge slope of polynomial - real, dimension(:,:),intent(inout) :: ppoly0_coefs !< Coefficients of polynomial - integer, intent(inout) :: degree !< The degree of the polynomials - real, optional, intent(in) :: h_neglect !< A negligibly small width for the - !! purpose of cell reconstructions - !! in the same units as h0. - real, optional, intent(in) :: h_neglect_edge !< A negligibly small width - !! for the purpose of edge value calculations - !! in the same units as h0. + type(interp_CS_type), intent(in) :: CS !< Interpolation control structure + integer, intent(in) :: n0 !< Number of cells on source grid + real, dimension(n0), intent(in) :: densities !< Actual cell densities + real, dimension(n0), intent(in) :: h0 !< cell widths on source grid + real, dimension(n0,2), intent(inout) :: ppoly0_E !< Edge value of polynomial + real, dimension(n0,2), intent(inout) :: ppoly0_S !< Edge slope of polynomial + real, dimension(n0,DEGREE_MAX+1), intent(inout) :: ppoly0_coefs !< Coefficients of polynomial + integer, intent(inout) :: degree !< The degree of the polynomials + real, optional, intent(in) :: h_neglect !< A negligibly small width for the + !! purpose of cell reconstructions + !! in the same units as h0. + real, optional, intent(in) :: h_neglect_edge !< A negligibly small width + !! for the purpose of edge value calculations + !! in the same units as h0. ! Local variables logical :: extrapolate @@ -106,8 +106,8 @@ subroutine regridding_set_ppolys(CS, densities, n0, h0, ppoly0_E, ppoly0_S, & case ( INTERPOLATION_P1M_H2 ) 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 ) + call edge_values_explicit_h2( n0, h0, densities, ppoly0_E ) + call P1M_interpolation( n0, h0, densities, ppoly0_E, ppoly0_coefs, h_neglect, answers_2018=CS%answers_2018 ) if (extrapolate) then call P1M_boundary_extrapolation( n0, h0, densities, ppoly0_E, ppoly0_coefs ) endif @@ -117,9 +117,9 @@ subroutine regridding_set_ppolys(CS, densities, n0, h0, ppoly0_E, ppoly0_S, & if ( n0 >= 4 ) then call edge_values_explicit_h4( n0, h0, densities, ppoly0_E, h_neglect_edge, answers_2018=CS%answers_2018 ) else - call edge_values_explicit_h2( n0, h0, densities, ppoly0_E, h_neglect_edge ) + call edge_values_explicit_h2( n0, h0, densities, ppoly0_E ) endif - call P1M_interpolation( n0, h0, densities, ppoly0_E, ppoly0_coefs, h_neglect ) + call P1M_interpolation( n0, h0, densities, ppoly0_E, ppoly0_coefs, h_neglect, answers_2018=CS%answers_2018 ) if (extrapolate) then call P1M_boundary_extrapolation( n0, h0, densities, ppoly0_E, ppoly0_coefs ) endif @@ -129,9 +129,9 @@ subroutine regridding_set_ppolys(CS, densities, n0, h0, ppoly0_E, ppoly0_S, & if ( n0 >= 4 ) then call edge_values_implicit_h4( n0, h0, densities, ppoly0_E, h_neglect_edge, answers_2018=CS%answers_2018 ) else - call edge_values_explicit_h2( n0, h0, densities, ppoly0_E, h_neglect_edge ) + call edge_values_explicit_h2( n0, h0, densities, ppoly0_E ) endif - call P1M_interpolation( n0, h0, densities, ppoly0_E, ppoly0_coefs, h_neglect ) + call P1M_interpolation( n0, h0, densities, ppoly0_E, ppoly0_coefs, h_neglect, answers_2018=CS%answers_2018 ) if (extrapolate) then call P1M_boundary_extrapolation( n0, h0, densities, ppoly0_E, ppoly0_coefs ) endif @@ -147,15 +147,15 @@ subroutine regridding_set_ppolys(CS, densities, n0, h0, ppoly0_E, ppoly0_S, & if ( n0 >= 4 ) then degree = DEGREE_2 call edge_values_explicit_h4( n0, h0, densities, ppoly0_E, h_neglect_edge, answers_2018=CS%answers_2018 ) - call PPM_reconstruction( n0, h0, densities, ppoly0_E, ppoly0_coefs, h_neglect ) + call PPM_reconstruction( n0, h0, densities, ppoly0_E, ppoly0_coefs, h_neglect, answers_2018=CS%answers_2018 ) if (extrapolate) then call PPM_boundary_extrapolation( n0, h0, densities, ppoly0_E, & ppoly0_coefs, h_neglect ) 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 ) + call edge_values_explicit_h2( n0, h0, densities, ppoly0_E ) + call P1M_interpolation( n0, h0, densities, ppoly0_E, ppoly0_coefs, h_neglect, answers_2018=CS%answers_2018 ) if (extrapolate) then call P1M_boundary_extrapolation( n0, h0, densities, ppoly0_E, ppoly0_coefs ) endif @@ -165,15 +165,15 @@ subroutine regridding_set_ppolys(CS, densities, n0, h0, ppoly0_E, ppoly0_S, & if ( n0 >= 4 ) then degree = DEGREE_2 call edge_values_implicit_h4( n0, h0, densities, ppoly0_E, h_neglect_edge, answers_2018=CS%answers_2018 ) - call PPM_reconstruction( n0, h0, densities, ppoly0_E, ppoly0_coefs, h_neglect ) + call PPM_reconstruction( n0, h0, densities, ppoly0_E, ppoly0_coefs, h_neglect, answers_2018=CS%answers_2018 ) if (extrapolate) then call PPM_boundary_extrapolation( n0, h0, densities, ppoly0_E, & ppoly0_coefs, h_neglect ) 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 ) + call edge_values_explicit_h2( n0, h0, densities, ppoly0_E ) + call P1M_interpolation( n0, h0, densities, ppoly0_E, ppoly0_coefs, h_neglect, answers_2018=CS%answers_2018 ) if (extrapolate) then call P1M_boundary_extrapolation( n0, h0, densities, ppoly0_E, ppoly0_coefs ) endif @@ -185,15 +185,15 @@ 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, answers_2018=CS%answers_2018 ) call edge_slopes_implicit_h3( n0, h0, densities, ppoly0_S, h_neglect, answers_2018=CS%answers_2018 ) call P3M_interpolation( n0, h0, densities, ppoly0_E, ppoly0_S, & - ppoly0_coefs, h_neglect ) + ppoly0_coefs, h_neglect, answers_2018=CS%answers_2018 ) if (extrapolate) then call P3M_boundary_extrapolation( n0, h0, densities, ppoly0_E, ppoly0_S, & ppoly0_coefs, h_neglect, h_neglect_edge ) 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 ) + call edge_values_explicit_h2( n0, h0, densities, ppoly0_E ) + call P1M_interpolation( n0, h0, densities, ppoly0_E, ppoly0_coefs, h_neglect, answers_2018=CS%answers_2018 ) if (extrapolate) then call P1M_boundary_extrapolation( n0, h0, densities, ppoly0_E, ppoly0_coefs ) endif @@ -205,15 +205,15 @@ subroutine regridding_set_ppolys(CS, densities, n0, h0, ppoly0_E, ppoly0_S, & call edge_values_implicit_h6( n0, h0, densities, ppoly0_E, h_neglect_edge, answers_2018=CS%answers_2018 ) call edge_slopes_implicit_h5( n0, h0, densities, ppoly0_S, h_neglect, answers_2018=CS%answers_2018 ) call P3M_interpolation( n0, h0, densities, ppoly0_E, ppoly0_S, & - ppoly0_coefs, h_neglect ) + ppoly0_coefs, h_neglect, answers_2018=CS%answers_2018 ) if (extrapolate) then call P3M_boundary_extrapolation( n0, h0, densities, ppoly0_E, ppoly0_S, & ppoly0_coefs, h_neglect, h_neglect_edge ) 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 ) + call edge_values_explicit_h2( n0, h0, densities, ppoly0_E ) + call P1M_interpolation( n0, h0, densities, ppoly0_E, ppoly0_coefs, h_neglect, answers_2018=CS%answers_2018 ) if (extrapolate) then call P1M_boundary_extrapolation( n0, h0, densities, ppoly0_E, ppoly0_coefs ) endif @@ -225,15 +225,15 @@ 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, answers_2018=CS%answers_2018 ) call edge_slopes_implicit_h3( n0, h0, densities, ppoly0_S, h_neglect, answers_2018=CS%answers_2018 ) call PQM_reconstruction( n0, h0, densities, ppoly0_E, ppoly0_S, & - ppoly0_coefs, h_neglect ) + ppoly0_coefs, h_neglect, answers_2018=CS%answers_2018 ) if (extrapolate) then call PQM_boundary_extrapolation_v1( n0, h0, densities, ppoly0_E, ppoly0_S, & ppoly0_coefs, h_neglect ) 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 ) + call edge_values_explicit_h2( n0, h0, densities, ppoly0_E ) + call P1M_interpolation( n0, h0, densities, ppoly0_E, ppoly0_coefs, h_neglect, answers_2018=CS%answers_2018 ) if (extrapolate) then call P1M_boundary_extrapolation( n0, h0, densities, ppoly0_E, ppoly0_coefs ) endif @@ -245,20 +245,21 @@ subroutine regridding_set_ppolys(CS, densities, n0, h0, ppoly0_E, ppoly0_S, & call edge_values_implicit_h6( n0, h0, densities, ppoly0_E, h_neglect_edge, answers_2018=CS%answers_2018 ) call edge_slopes_implicit_h5( n0, h0, densities, ppoly0_S, h_neglect, answers_2018=CS%answers_2018 ) call PQM_reconstruction( n0, h0, densities, ppoly0_E, ppoly0_S, & - ppoly0_coefs, h_neglect ) + ppoly0_coefs, h_neglect, answers_2018=CS%answers_2018 ) if (extrapolate) then call PQM_boundary_extrapolation_v1( n0, h0, densities, ppoly0_E, ppoly0_S, & ppoly0_coefs, h_neglect ) 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 ) + call edge_values_explicit_h2( n0, h0, densities, ppoly0_E ) + call P1M_interpolation( n0, h0, densities, ppoly0_E, ppoly0_coefs, h_neglect, answers_2018=CS%answers_2018 ) if (extrapolate) then call P1M_boundary_extrapolation( n0, h0, densities, ppoly0_E, ppoly0_coefs ) endif endif end select + end subroutine regridding_set_ppolys !> Given target values (e.g., density), build new grid based on polynomial @@ -268,17 +269,18 @@ end subroutine regridding_set_ppolys !! are determined by finding the corresponding target interface densities. subroutine interpolate_grid( n0, h0, x0, ppoly0_E, ppoly0_coefs, & target_values, degree, n1, h1, x1, answers_2018 ) - integer, intent(in) :: n0 !< Number of points on source grid - real, dimension(:), intent(in) :: h0 !< Thicknesses of source grid cells - real, dimension(:), intent(in) :: x0 !< Source interface positions - real, dimension(:,:), intent(in) :: ppoly0_E !< Edge values of interpolating polynomials - real, dimension(:,:), intent(in) :: ppoly0_coefs !< Coefficients of interpolating polynomials - real, dimension(:), intent(in) :: target_values !< Target values of interfaces - integer, intent(in) :: degree !< Degree of interpolating polynomials - integer, intent(in) :: n1 !< Number of points on target grid - real, dimension(:), intent(inout) :: h1 !< Thicknesses of target grid cells - real, dimension(:), intent(inout) :: x1 !< Target interface positions - logical, optional, intent(in) :: answers_2018 !< If true use older, less acccurate expressions. + integer, intent(in) :: n0 !< Number of points on source grid + integer, intent(in) :: n1 !< Number of points on target grid + real, dimension(n0), intent(in) :: h0 !< Thicknesses of source grid cells + real, dimension(n0+1), intent(in) :: x0 !< Source interface positions + real, dimension(n0,2), intent(in) :: ppoly0_E !< Edge values of interpolating polynomials + real, dimension(n0,DEGREE_MAX+1), & + intent(in) :: ppoly0_coefs !< Coefficients of interpolating polynomials + real, dimension(n1+1), intent(in) :: target_values !< Target values of interfaces + integer, intent(in) :: degree !< Degree of interpolating polynomials + real, dimension(n1), intent(inout) :: h1 !< Thicknesses of target grid cells + real, dimension(n1+1), intent(inout) :: x1 !< Target interface positions + logical, optional, intent(in) :: answers_2018 !< If true use older, less acccurate expressions. ! Local variables logical :: use_2018_answers ! If true use older, less acccurate expressions. @@ -304,19 +306,19 @@ end subroutine interpolate_grid !> Build a grid by interpolating for target values subroutine build_and_interpolate_grid(CS, densities, n0, h0, x0, target_values, & n1, h1, x1, h_neglect, h_neglect_edge) - type(interp_CS_type), intent(in) :: CS !< A control structure for regrid_interp - real, dimension(:), intent(in) :: densities !< Input cell densities [kg m-3] - real, dimension(:), intent(in) :: target_values !< Target values of interfaces - integer, intent(in) :: n0 !< The number of points on the input grid - real, dimension(:), intent(in) :: h0 !< Initial cell widths - real, dimension(:), intent(in) :: x0 !< Source interface positions - integer, intent(in) :: n1 !< The number of points on the output grid - real, dimension(:), intent(inout) :: h1 !< Output cell widths - real, dimension(:), intent(inout) :: x1 !< Target interface positions - real, optional, intent(in) :: h_neglect !< A negligibly small width for the + type(interp_CS_type), intent(in) :: CS !< A control structure for regrid_interp + integer, intent(in) :: n0 !< The number of points on the input grid + integer, intent(in) :: n1 !< The number of points on the output grid + real, dimension(n0), intent(in) :: densities !< Input cell densities [kg m-3] + real, dimension(n1+1), intent(in) :: target_values !< Target values of interfaces + real, dimension(n0), intent(in) :: h0 !< Initial cell widths + real, dimension(n0+1), intent(in) :: x0 !< Source interface positions + real, dimension(n1), intent(inout) :: h1 !< Output cell widths + real, dimension(n1+1), intent(inout) :: x1 !< Target interface positions + real, optional, intent(in) :: h_neglect !< A negligibly small width for the !! purpose of cell reconstructions !! in the same units as h0. - real, optional, intent(in) :: h_neglect_edge !< A negligibly small width + real, optional, intent(in) :: h_neglect_edge !< A negligibly small width !! for the purpose of edge value calculations !! in the same units as h0. @@ -350,10 +352,10 @@ function get_polynomial_coordinate( N, h, x_g, ppoly_E, ppoly_coefs, & target_value, degree, answers_2018 ) result ( x_tgt ) ! Arguments integer, intent(in) :: N !< Number of grid cells - real, dimension(:), intent(in) :: h !< Grid cell thicknesses - real, dimension(:), intent(in) :: x_g !< Grid interface locations - real, dimension(:,:), intent(in) :: ppoly_E !< Edge values of interpolating polynomials - real, dimension(:,:), intent(in) :: ppoly_coefs !< Coefficients of interpolating polynomials + real, dimension(N), intent(in) :: h !< Grid cell thicknesses + real, dimension(N+1), intent(in) :: x_g !< Grid interface locations + real, dimension(N,2), intent(in) :: ppoly_E !< Edge values of interpolating polynomials + real, dimension(N,DEGREE_MAX+1), intent(in) :: ppoly_coefs !< Coefficients of interpolating polynomials real, intent(in) :: target_value !< Target value to find position for integer, intent(in) :: degree !< Degree of the interpolating polynomials logical, optional, intent(in) :: answers_2018 !< If true use older, less acccurate expressions. diff --git a/src/ALE/regrid_solvers.F90 b/src/ALE/regrid_solvers.F90 index 8ee7ab29b2..3f8923b585 100644 --- a/src/ALE/regrid_solvers.F90 +++ b/src/ALE/regrid_solvers.F90 @@ -7,52 +7,50 @@ module regrid_solvers implicit none ; private -public :: solve_linear_system, solve_tridiagonal_system +public :: solve_linear_system, solve_tridiagonal_system, solve_diag_dominant_tridiag contains -!> Solve the linear system AX = B by Gaussian elimination +!> Solve the linear system AX = R by Gaussian elimination !! !! 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. -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 +!! The matrix A must be square and its size must be that of the vectors R and X. +subroutine solve_linear_system( A, R, X, N, answers_2018 ) + integer, intent(in) :: N !< The size of the system + real, dimension(N,N), intent(inout) :: A !< The matrix being inverted [nondim] + real, dimension(N), intent(inout) :: R !< system right-hand side [A] + real, dimension(N), intent(inout) :: X !< solution vector [A] + logical, optional, intent(in) :: answers_2018 !< If true use older, less acccurate expressions. ! Local variables - integer :: i, j, k real, parameter :: eps = 0.0 ! Minimum pivot magnitude allowed - real :: factor - real :: pivot - real :: swap_a, swap_b - logical :: found_pivot ! boolean indicating whether - ! a pivot has been found - ! Loop on rows - do i = 1,system_size-1 + real :: factor ! The factor that eliminates the leading nonzero element in a row. + real :: pivot, I_pivot ! The pivot value and its reciprocal [nondim] + real :: swap_a, swap_b + logical :: found_pivot ! If true, a pivot has been found + logical :: old_answers ! If true, use expressions that give the original (2008 through 2018) MOM6 answers + integer :: i, j, k - found_pivot = .false. + old_answers = .true. ; if (present(answers_2018)) old_answers = answers_2018 - ! Start to look for a pivot in row i. If the pivot - ! in row i -- which is the current row -- is not valid, - ! we keep looking for a valid pivot by searching the - ! 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 <= system_size ) ) + ! Loop on rows to transform the problem into multiplication by an upper-right matrix. + do i = 1,N-1 - 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 - endif + ! Start to look for a pivot in the current row, i. If the pivot in row i is not valid, + ! keep looking for a valid pivot by searching the 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. + found_pivot = .false. + k = i + do while ( ( .NOT. found_pivot ) .AND. ( k <= N ) ) + if ( abs( A(k,i) ) > eps ) then ! A valid pivot has been found + found_pivot = .true. + else ! Seek a valid pivot in the next row + k = k + 1 + endif enddo ! end loop to find pivot - ! If no pivot could be found, the system is singular and we need - ! to end the execution + ! If no pivot could be found, the system is singular. if ( .NOT. found_pivot ) then write(0,*) ' A=',A call MOM_error( FATAL, 'The linear system is singular !' ) @@ -61,86 +59,152 @@ subroutine solve_linear_system( A, B, X, system_size ) ! 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 /= i ) then - do j = 1,system_size - swap_a = A(i,j) - A(i,j) = A(k,j) - A(k,j) = swap_a + do j = 1,N + swap_a = A(i,j) ; A(i,j) = A(k,j) ; A(k,j) = swap_a enddo - swap_b = B(i) - B(i) = B(k) - B(k) = swap_b + swap_b = R(i) ; R(i) = R(k) ; R(k) = swap_b 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 - enddo - B(i) = B(i) / pivot + ! Transform pivot to 1 by dividing the entire row (right-hand side included) by the pivot + if (old_answers) then + pivot = A(i,i) + do j = i,N ; A(i,j) = A(i,j) / pivot ; enddo + R(i) = R(i) / pivot + else + I_pivot = 1.0 / A(i,i) + A(i,i) = 1.0 + do j = i+1,N ; A(i,j) = A(i,j) * I_pivot ; enddo + R(i) = R(i) * I_pivot + endif ! #INV: At this point, A(i,i) is a suitable pivot and it is equal to 1 - ! Put zeros in column for all rows below that containing - ! pivot (which is row i) - do k = (i+1),system_size ! k is the row index + ! Put zeros in column for all rows below that contain the pivot (which is row i) + do k = i+1,N ! k is the row index factor = A(k,i) - do j = (i+1),system_size ! j is the column index + ! A(k,i) = 0.0 ! These elements are not used again, so this line can be skipped for speed. + do j = i+1,N ! j is the column index A(k,j) = A(k,j) - factor * A(i,j) enddo - B(k) = B(k) - factor * B(i) + R(k) = R(k) - factor * R(i) enddo enddo ! end loop on i - - ! Solve system by back substituting - X(system_size) = B(system_size) / A(system_size,system_size) - do i = system_size-1,1,-1 ! loop on rows, starting from second to last row - X(i) = B(i) - do j = (i+1),system_size + ! Solve system by back substituting in what is now an upper-right matrix. + X(N) = R(N) / A(N,N) ! The last row is now trivially solved. + do i = N-1,1,-1 ! loop on rows, starting from second to last row + X(i) = R(i) + do j = i+1,N X(i) = X(i) - A(i,j) * X(j) enddo - X(i) = X(i) / A(i,i) + if (old_answers) X(i) = X(i) / A(i,i) enddo end subroutine solve_linear_system -!> Solve the tridiagonal system AX = B +!> Solve the tridiagonal system AX = R !! -!! This routine uses Thomas's algorithm to solve the tridiagonal system AX = B. +!! This routine uses Thomas's algorithm to solve the tridiagonal system AX = R. !! (A is made up of lower, middle and upper diagonals) -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 +subroutine solve_tridiagonal_system( Al, Ad, Au, R, X, N, answers_2018 ) + integer, intent(in) :: N !< The size of the system + real, dimension(N), intent(in) :: Ad !< Matrix center diagonal + real, dimension(N), intent(in) :: Al !< Matrix lower diagonal + real, dimension(N), intent(in) :: Au !< Matrix upper diagonal + real, dimension(N), intent(in) :: R !< system right-hand side + real, dimension(N), intent(out) :: X !< solution vector + logical, optional, intent(in) :: answers_2018 !< If true use older, less acccurate expressions. ! Local variables - integer :: k ! Loop index - integer :: N ! system size + real, dimension(N) :: pivot, Al_piv + real, dimension(N) :: c1 ! Au / pivot for the backward sweep + real :: I_pivot ! The inverse of the most recent pivot + integer :: k ! Loop index + logical :: old_answers ! If true, use expressions that give the original (2008 through 2018) MOM6 answers + + old_answers = .true. ; if (present(answers_2018)) old_answers = answers_2018 + + if (old_answers) then + ! This version gives the same answers as the original (2008 through 2018) MOM6 code + ! Factorization and forward sweep + pivot(1) = Ad(1) + X(1) = R(1) + do k = 2,N + Al_piv(k) = Al(k) / pivot(k-1) + pivot(k) = Ad(k) - Al_piv(k) * Au(k-1) + X(k) = R(k) - Al_piv(k) * X(k-1) + enddo + + ! Backward sweep + X(N) = R(N) / pivot(N) ! This should be X(N) / pivot(N), but is OK if Al(N) = 0. + do k = N-1,1,-1 + X(k) = ( X(k) - Au(k)*X(k+1) ) / pivot(k) + enddo + else + ! This is a more typical implementation of a tridiagonal solver than the one above. + ! It is mathematically equivalent but differs at roundoff, which can cascade up to larger values. + + ! Factorization and forward sweep + I_pivot = 1.0 / Ad(1) + X(1) = R(1) * I_pivot + do k = 2,N + c1(K-1) = Au(k-1) * I_pivot + I_pivot = 1.0 / (Ad(k) - Al(k) * c1(K-1)) + X(k) = (R(k) - Al(k) * X(k-1)) * I_pivot + enddo + ! Backward sweep + do k = N-1,1,-1 + X(k) = X(k) - c1(K) * X(k+1) + enddo - N = system_size + endif - ! Factorization - do k = 1,N-1 - Al(k+1) = Al(k+1) / Ad(k) - Ad(k+1) = Ad(k+1) - Al(k+1) * Au(k) - enddo +end subroutine solve_tridiagonal_system - ! Forward sweep - do k = 2,N - B(k) = B(k) - Al(k) * B(k-1) - enddo +!> Solve the tridiagonal system AX = R +!! +!! This routine uses a variant of Thomas's algorithm to solve the tridiagonal system AX = R, in +!! a form that is guaranteed to avoid dividing by a zero pivot. The matrix A is made up of +!! lower (Al) and upper diagonals (Au) and a central diagonal Ad = Ac+Al+Au, where +!! Al, Au, and Ac are all positive (or negative) definite. However when Ac is smaller than +!! roundoff compared with (Al+Au), the answers are prone to inaccuracy. +subroutine solve_diag_dominant_tridiag( Al, Ac, Au, R, X, N ) + integer, intent(in) :: N !< The size of the system + real, dimension(N), intent(in) :: Ac !< Matrix center diagonal offset from Al + Au + real, dimension(N), intent(in) :: Al !< Matrix lower diagonal + real, dimension(N), intent(in) :: Au !< Matrix upper diagonal + real, dimension(N), intent(in) :: R !< system right-hand side + real, dimension(N), intent(out) :: X !< solution vector + ! Local variables + real, dimension(N) :: c1 ! Au / pivot for the backward sweep + real :: d1 ! The next value of 1.0 - c1 + real :: I_pivot ! The inverse of the most recent pivot + real :: denom_t1 ! The first term in the denominator of the inverse of the pivot. + integer :: k ! Loop index + + ! Factorization and forward sweep, in a form that will never give a division by a + ! zero pivot for positive definite Ac, Al, and Au. + I_pivot = 1.0 / (Ac(1) + Au(1)) + d1 = Ac(1) * I_pivot + c1(1) = Au(1) * I_pivot + X(1) = R(1) * I_pivot + do k=2,N-1 + denom_t1 = Ac(k) + d1 * Al(k) + I_pivot = 1.0 / (denom_t1 + Au(k)) + d1 = denom_t1 * I_pivot + c1(k) = Au(k) * I_pivot + X(k) = (R(k) - Al(k) * X(k-1)) * I_pivot + enddo + I_pivot = 1.0 / (Ac(N) + d1 * Al(N)) + X(N) = (R(N) - Al(N) * X(N-1)) * I_pivot ! 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) + do k=N-1,1,-1 + X(k) = X(k) - c1(k) * X(k+1) enddo -end subroutine solve_tridiagonal_system +end subroutine solve_diag_dominant_tridiag + !> \namespace regrid_solvers !! @@ -148,6 +212,6 @@ end subroutine solve_tridiagonal_system !! L. White !! !! This module contains solvers of linear systems. -!! These routines could (should ?) be replaced later by more efficient ones. +!! These routines have now been updated for greater efficiency, especially in special cases. end module regrid_solvers From c58fb9b723c097a7b43fd93a2dc6d65a10a89643 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Tue, 17 Dec 2019 16:28:08 -0500 Subject: [PATCH 010/316] (*)Modified MOM_remapping to use new regridding Modified MOM_remapping and MOM_ALE to use and test new regridding options. Answers only change when REMAPPING_2018_ANSWERS is false; otherwise they are bitwise identical. --- src/ALE/MOM_ALE.F90 | 9 ++++----- src/ALE/MOM_remapping.F90 | 20 +++++++++++--------- 2 files changed, 15 insertions(+), 14 deletions(-) diff --git a/src/ALE/MOM_ALE.F90 b/src/ALE/MOM_ALE.F90 index 97232b22ca..c6b68bf646 100644 --- a/src/ALE/MOM_ALE.F90 +++ b/src/ALE/MOM_ALE.F90 @@ -53,9 +53,6 @@ module MOM_ALE use regrid_edge_values, only : edge_values_implicit_h4 use PLM_functions, only : PLM_reconstruction, PLM_boundary_extrapolation use PPM_functions, only : PPM_reconstruction, PPM_boundary_extrapolation -use P1M_functions, only : P1M_interpolation, P1M_boundary_extrapolation -use P3M_functions, only : P3M_interpolation, P3M_boundary_extrapolation - implicit none ; private #include @@ -1131,7 +1128,8 @@ subroutine pressure_gradient_ppm( CS, S_t, S_b, T_t, T_b, G, GV, tv, h, bdry_ext !### 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, & answers_2018=CS%answers_2018 ) - call PPM_reconstruction( GV%ke, hTmp, tmp, ppol_E, ppol_coefs, h_neglect ) + call PPM_reconstruction( GV%ke, hTmp, tmp, ppol_E, ppol_coefs, h_neglect, & + answers_2018=CS%answers_2018 ) if (bdry_extrap) & call PPM_boundary_extrapolation( GV%ke, hTmp, tmp, ppol_E, ppol_coefs, h_neglect ) @@ -1147,7 +1145,8 @@ subroutine pressure_gradient_ppm( CS, S_t, S_b, T_t, T_b, G, GV, tv, h, bdry_ext !### 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, & answers_2018=CS%answers_2018 ) - call PPM_reconstruction( GV%ke, hTmp, tmp, ppol_E, ppol_coefs, h_neglect ) + call PPM_reconstruction( GV%ke, hTmp, tmp, ppol_E, ppol_coefs, h_neglect, & + answers_2018=CS%answers_2018 ) if (bdry_extrap) & call PPM_boundary_extrapolation(GV%ke, hTmp, tmp, ppol_E, ppol_coefs, h_neglect ) diff --git a/src/ALE/MOM_remapping.F90 b/src/ALE/MOM_remapping.F90 index d7f8343993..5b91eba045 100644 --- a/src/ALE/MOM_remapping.F90 +++ b/src/ALE/MOM_remapping.F90 @@ -399,14 +399,14 @@ subroutine build_reconstructions_1d( CS, n0, h0, u0, ppoly_r_coefs, & iMethod = INTEGRATION_PLM case ( REMAPPING_PPM_H4 ) call edge_values_explicit_h4( n0, h0, u0, ppoly_r_E, h_neglect_edge, answers_2018=CS%answers_2018 ) - call PPM_reconstruction( n0, h0, u0, ppoly_r_E, ppoly_r_coefs, h_neglect ) + call PPM_reconstruction( n0, h0, u0, ppoly_r_E, ppoly_r_coefs, h_neglect, answers_2018=CS%answers_2018 ) if ( CS%boundary_extrapolation ) then 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, answers_2018=CS%answers_2018 ) - call PPM_reconstruction( n0, h0, u0, ppoly_r_E, ppoly_r_coefs, h_neglect ) + call PPM_reconstruction( n0, h0, u0, ppoly_r_E, ppoly_r_coefs, h_neglect, answers_2018=CS%answers_2018 ) if ( CS%boundary_extrapolation ) then call PPM_boundary_extrapolation( n0, h0, u0, ppoly_r_E, ppoly_r_coefs, h_neglect ) endif @@ -414,7 +414,8 @@ subroutine build_reconstructions_1d( CS, n0, h0, u0, ppoly_r_coefs, & case ( REMAPPING_PQM_IH4IH3 ) call edge_values_implicit_h4( n0, h0, u0, ppoly_r_E, h_neglect_edge, answers_2018=CS%answers_2018 ) call edge_slopes_implicit_h3( n0, h0, u0, ppoly_r_S, h_neglect, answers_2018=CS%answers_2018 ) - call PQM_reconstruction( n0, h0, u0, ppoly_r_E, ppoly_r_S, ppoly_r_coefs, h_neglect ) + call PQM_reconstruction( n0, h0, u0, ppoly_r_E, ppoly_r_S, ppoly_r_coefs, h_neglect, & + answers_2018=CS%answers_2018 ) if ( CS%boundary_extrapolation ) then call PQM_boundary_extrapolation_v1( n0, h0, u0, ppoly_r_E, ppoly_r_S, & ppoly_r_coefs, h_neglect ) @@ -423,7 +424,8 @@ subroutine build_reconstructions_1d( CS, n0, h0, u0, ppoly_r_coefs, & case ( REMAPPING_PQM_IH6IH5 ) call edge_values_implicit_h6( n0, h0, u0, ppoly_r_E, h_neglect_edge, answers_2018=CS%answers_2018 ) call edge_slopes_implicit_h5( n0, h0, u0, ppoly_r_S, h_neglect, answers_2018=CS%answers_2018 ) - call PQM_reconstruction( n0, h0, u0, ppoly_r_E, ppoly_r_S, ppoly_r_coefs, h_neglect ) + call PQM_reconstruction( n0, h0, u0, ppoly_r_E, ppoly_r_S, ppoly_r_coefs, h_neglect, & + answers_2018=CS%answers_2018 ) if ( CS%boundary_extrapolation ) then call PQM_boundary_extrapolation_v1( n0, h0, u0, ppoly_r_E, ppoly_r_S, & ppoly_r_coefs, h_neglect ) @@ -1630,7 +1632,7 @@ logical function remapping_unit_tests(verbose) v = verbose h_neglect = hNeglect_dflt h_neglect_edge = 1.0e-10 - answers_2018 = .true. + answers_2018 = .false. ! .true. write(*,*) '==== MOM_remapping: remapping_unit_tests =================' remapping_unit_tests = .false. ! Normally return false @@ -1677,7 +1679,7 @@ logical function remapping_unit_tests(verbose) ppoly0_coefs(:,:) = 0.0 call edge_values_explicit_h4( n0, h0, u0, ppoly0_E, h_neglect=1e-10, answers_2018=answers_2018 ) - call PPM_reconstruction( n0, h0, u0, ppoly0_E, ppoly0_coefs, h_neglect ) + call PPM_reconstruction( n0, h0, u0, ppoly0_E, ppoly0_coefs, h_neglect, answers_2018=answers_2018 ) call PPM_boundary_extrapolation( n0, h0, u0, ppoly0_E, ppoly0_coefs, h_neglect ) u1(:) = 0. call remapByProjection( n0, h0, u0, ppoly0_E, ppoly0_coefs, & @@ -1814,7 +1816,7 @@ logical function remapping_unit_tests(verbose) 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_coefs(1:5,:), h_neglect ) + ppoly0_coefs(1:5,:), h_neglect, answers_2018=answers_2018 ) remapping_unit_tests = remapping_unit_tests .or. & test_answer(v, 5, ppoly0_coefs(:,1), (/1.,2.,4.,6.,9./), 'Line PPM: P0') remapping_unit_tests = remapping_unit_tests .or. & @@ -1830,7 +1832,7 @@ logical function remapping_unit_tests(verbose) 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_coefs(1:5,:), h_neglect ) + ppoly0_coefs(1:5,:), h_neglect, answers_2018=answers_2018 ) 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. & @@ -1845,7 +1847,7 @@ logical function remapping_unit_tests(verbose) 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_coefs(1:5,:), h_neglect ) + ppoly0_coefs(1:5,:), h_neglect, answers_2018=answers_2018 ) 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. & From 730de2b8353652be470e340abe5a12441acc51d4 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Tue, 17 Dec 2019 16:31:45 -0500 Subject: [PATCH 011/316] +Set REMAPPING_2018_ANSWERS in 6 modules Read and set REMAPPING_2018_ANSWERS via calls to initialize_remapping in 6 modules. This required a new argument to diag_remap_init. Also removed unused h_neglect variables from calculate_CVMix_tidal. By default, all answers are bitwise identical unless REMAPPING_2018_ANSWERS is false. --- src/core/MOM_open_boundary.F90 | 14 +++++++++--- src/framework/MOM_diag_mediator.F90 | 10 ++++++++- src/framework/MOM_diag_remap.F90 | 15 +++++++++++-- .../MOM_state_initialization.F90 | 14 ++++++++++-- .../MOM_tracer_initialization_from_Z.F90 | 13 ++++++++++- .../vertical/MOM_ALE_sponge.F90 | 22 +++++++++++++++++-- .../vertical/MOM_tidal_mixing.F90 | 7 ------ src/tracer/MOM_neutral_diffusion.F90 | 13 +++++++++-- 8 files changed, 88 insertions(+), 20 deletions(-) diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index f35748dd4a..0f0205cb22 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -555,6 +555,7 @@ subroutine initialize_segment_data(G, OBC, PF) character(len=32) :: remappingScheme character(len=256) :: mesg ! Message for error messages. logical :: check_reconstruction, check_remapping, force_bounds_in_subcell + logical :: answers_2018, default_2018_answers integer, dimension(4) :: siz,siz2 integer :: is, ie, js, je integer :: isd, ied, jsd, jed @@ -591,14 +592,21 @@ subroutine initialize_segment_data(G, OBC, PF) "If true, the values on the intermediate grid used for remapping "//& "are forced to be bounded, which might not be the case due to "//& "round off.", default=.false.,do_not_log=.true.) - call get_param(PF, mdl, "BRUSHCUTTER_MODE", OBC%brushcutter_mode, & + call get_param(PF, mdl, "BRUSHCUTTER_MODE", OBC%brushcutter_mode, & "If true, read external OBC data on the supergrid.", & default=.false.) + call get_param(PF, mdl, "DEFAULT_2018_ANSWERS", default_2018_answers, & + "This sets the default value for the various _2018_ANSWERS parameters.", & + default=.true.) + call get_param(PF, mdl, "REMAPPING_2018_ANSWERS", answers_2018, & + "If true, use the order of arithmetic and expressions that recover the "//& + "answers from the end of 2018. Otherwise, use updated and more robust "//& + "forms of the same expressions.", default=default_2018_answers) allocate(OBC%remap_CS) call initialize_remapping(OBC%remap_CS, remappingScheme, boundary_extrapolation = .false., & - check_reconstruction=check_reconstruction, & - check_remapping=check_remapping, force_bounds_in_subcell=force_bounds_in_subcell) + check_reconstruction=check_reconstruction, check_remapping=check_remapping, & + force_bounds_in_subcell=force_bounds_in_subcell, answers_2018=answers_2018) if (OBC%user_BCs_set_globally) return diff --git a/src/framework/MOM_diag_mediator.F90 b/src/framework/MOM_diag_mediator.F90 index 5fd21bd490..1fc012b7b9 100644 --- a/src/framework/MOM_diag_mediator.F90 +++ b/src/framework/MOM_diag_mediator.F90 @@ -2986,6 +2986,7 @@ subroutine diag_mediator_init(G, GV, US, nz, param_file, diag_cs, doc_file_dir) ! Local variables integer :: ios, i, new_unit logical :: opened, new_file + logical :: answers_2018, default_2018_answers character(len=8) :: this_pe character(len=240) :: doc_file, doc_file_dflt, doc_path character(len=240), allocatable :: diag_coords(:) @@ -3012,6 +3013,13 @@ subroutine diag_mediator_init(G, GV, US, nz, param_file, diag_cs, doc_file_dir) 'The number of diagnostic vertical coordinates to use. '//& 'For each coordinate, an entry in DIAG_COORDS must be provided.', & default=1) + call get_param(param_file, mdl, "DEFAULT_2018_ANSWERS", default_2018_answers, & + "This sets the default value for the various _2018_ANSWERS parameters.", & + default=.true.) + call get_param(param_file, mdl, "REMAPPING_2018_ANSWERS", answers_2018, & + "If true, use the order of arithmetic and expressions that recover the "//& + "answers from the end of 2018. Otherwise, use updated and more robust "//& + "forms of the same expressions.", default=default_2018_answers) if (diag_cs%num_diag_coords>0) then allocate(diag_coords(diag_cs%num_diag_coords)) if (diag_cs%num_diag_coords==1) then ! The default is to provide just one instance of Z* @@ -3030,7 +3038,7 @@ subroutine diag_mediator_init(G, GV, US, nz, param_file, diag_cs, doc_file_dir) allocate(diag_cs%diag_remap_cs(diag_cs%num_diag_coords)) ! Initialize each diagnostic vertical coordinate do i=1, diag_cs%num_diag_coords - call diag_remap_init(diag_cs%diag_remap_cs(i), diag_coords(i)) + call diag_remap_init(diag_cs%diag_remap_cs(i), diag_coords(i), answers_2018=answers_2018) enddo deallocate(diag_coords) endif diff --git a/src/framework/MOM_diag_remap.F90 b/src/framework/MOM_diag_remap.F90 index 372d6d65cc..8855af9caa 100644 --- a/src/framework/MOM_diag_remap.F90 +++ b/src/framework/MOM_diag_remap.F90 @@ -115,15 +115,21 @@ module MOM_diag_remap real, dimension(:), allocatable :: dz !< Nominal layer thicknesses integer :: interface_axes_id = 0 !< Vertical axes id for remapping at interfaces integer :: layer_axes_id = 0 !< Vertical axes id for remapping on layers + logical :: answers_2018 !< If true, use the order of arithmetic and expressions for remapping + !! that recover the answers from the end of 2018. Otherwise, use + !! updated more robust forms of the same expressions. end type diag_remap_ctrl contains !> Initialize a diagnostic remapping type with the given vertical coordinate. -subroutine diag_remap_init(remap_cs, coord_tuple) +subroutine diag_remap_init(remap_cs, coord_tuple, answers_2018) type(diag_remap_ctrl), intent(inout) :: remap_cs !< Diag remapping control structure character(len=*), intent(in) :: coord_tuple !< A string in form of !! MODULE_SUFFIX PARAMETER_SUFFIX COORDINATE_NAME + logical, intent(in) :: answers_2018 !< If true, use the order of arithmetic and expressions + !! for remapping that recover the answers from the end of 2018. + !! Otherwise, use more robust forms of the same expressions. remap_cs%diag_module_suffix = trim(extractWord(coord_tuple, 1)) remap_cs%diag_coord_name = trim(extractWord(coord_tuple, 2)) @@ -132,6 +138,7 @@ subroutine diag_remap_init(remap_cs, coord_tuple) remap_cs%configured = .false. remap_cs%initialized = .false. remap_cs%used = .false. + remap_cs%answers_2018 = answers_2018 remap_cs%nz = 0 end subroutine diag_remap_init @@ -295,7 +302,8 @@ subroutine diag_remap_update(remap_cs, G, GV, US, h, T, S, eqn_of_state) if (.not. remap_cs%initialized) then ! Initialize remapping and regridding on the first call - call initialize_remapping(remap_cs%remap_cs, 'PPM_IH4', boundary_extrapolation=.false.) + call initialize_remapping(remap_cs%remap_cs, 'PPM_IH4', boundary_extrapolation=.false., & + answers_2018=remap_cs%answers_2018) allocate(remap_cs%h(G%isd:G%ied,G%jsd:G%jed, nz)) remap_cs%initialized = .true. endif @@ -362,6 +370,9 @@ subroutine diag_remap_do_remap(remap_cs, G, GV, h, staggered_in_x, staggered_in_ 'diag_remap_do_remap: Remap field and thickness z-axes do not match.') !### Try replacing both of these with GV%H_subroundoff + ! if (remap_cs%answers_2018) then + ! h_neglect = GV%H_subroundoff ; h_neglect_edge = GV%H_subroundoff + ! elseif (GV%Boussinesq) then if (GV%Boussinesq) then h_neglect = GV%m_to_H*1.0e-30 ; h_neglect_edge = GV%m_to_H*1.0e-10 else diff --git a/src/initialization/MOM_state_initialization.F90 b/src/initialization/MOM_state_initialization.F90 index ff08912191..c370cece88 100644 --- a/src/initialization/MOM_state_initialization.F90 +++ b/src/initialization/MOM_state_initialization.F90 @@ -2011,6 +2011,7 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, G, GV, US, PF, just_read_param type(remapping_CS) :: remapCS ! Remapping parameters and work arrays logical :: homogenize, useALEremapping, remap_full_column, remap_general, remap_old_alg + logical :: answers_2018, default_2018_answers logical :: use_ice_shelf character(len=10) :: remappingScheme real :: tempAvg, saltAvg @@ -2088,6 +2089,15 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, G, GV, US, PF, just_read_param "If false, uses the preferred remapping algorithm for initialization. "//& "If true, use an older, less robust algorithm for remapping.", & default=.true., do_not_log=just_read) + if (useALEremapping) then + call get_param(PF, mdl, "DEFAULT_2018_ANSWERS", default_2018_answers, & + "This sets the default value for the various _2018_ANSWERS parameters.", & + default=.true.) + call get_param(PF, mdl, "REMAPPING_2018_ANSWERS", answers_2018, & + "If true, use the order of arithmetic and expressions that recover the "//& + "answers from the end of 2018. Otherwise, use updated and more robust "//& + "forms of the same expressions.", default=default_2018_answers) + endif call get_param(PF, mdl, "ICE_SHELF", use_ice_shelf, default=.false.) if (use_ice_shelf) then call get_param(PF, mdl, "ICE_THICKNESS_FILE", ice_shelf_file, & @@ -2256,8 +2266,8 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, G, GV, US, PF, just_read_param deallocate( hTarget ) endif - ! Now remap from source grid to target grid - call initialize_remapping( remapCS, remappingScheme, boundary_extrapolation=.false. ) ! Reconstruction parameters + ! Now remap from source grid to target grid, first setting reconstruction parameters + call initialize_remapping( remapCS, remappingScheme, boundary_extrapolation=.false., answers_2018=answers_2018 ) if (remap_general) then call set_regrid_params( regridCS, min_thickness=0. ) tv_loc = tv diff --git a/src/initialization/MOM_tracer_initialization_from_Z.F90 b/src/initialization/MOM_tracer_initialization_from_Z.F90 index 08fb487bc5..553a25379e 100644 --- a/src/initialization/MOM_tracer_initialization_from_Z.F90 +++ b/src/initialization/MOM_tracer_initialization_from_Z.F90 @@ -90,6 +90,7 @@ subroutine MOM_initialize_tracer_from_Z(h, tr, G, GV, US, PF, src_file, src_var_ real :: missing_value integer :: nPoints integer :: id_clock_routine, id_clock_ALE + logical :: answers_2018, default_2018_answers logical :: reentrant_x, tripolar_n id_clock_routine = cpu_clock_id('(Initialize tracer from Z)', grain=CLOCK_ROUTINE) @@ -111,6 +112,15 @@ subroutine MOM_initialize_tracer_from_Z(h, tr, G, GV, US, PF, src_file, src_var_ call get_param(PF, mdl, "Z_INIT_REMAPPING_SCHEME", remapScheme, & "The remapping scheme to use if using Z_INIT_ALE_REMAPPING is True.", & default="PLM") + if (useALE) then + call get_param(PF, mdl, "DEFAULT_2018_ANSWERS", default_2018_answers, & + "This sets the default value for the various _2018_ANSWERS parameters.", & + default=.true.) + call get_param(PF, mdl, "REMAPPING_2018_ANSWERS", answers_2018, & + "If true, use the order of arithmetic and expressions that recover the "//& + "answers from the end of 2018. Otherwise, use updated and more robust "//& + "forms of the same expressions.", default=default_2018_answers) + endif ! These are model grid properties, but being applied to the data grid for now. ! need to revisit this (mjh) @@ -140,7 +150,8 @@ subroutine MOM_initialize_tracer_from_Z(h, tr, G, GV, US, PF, src_file, src_var_ ! First we reserve a work space for reconstructions of the source data allocate( h1(kd) ) allocate( hSrc(isd:ied,jsd:jed,kd) ) - call initialize_remapping( remapCS, remapScheme, boundary_extrapolation=.false. ) ! Data for reconstructions + ! Set parameters for reconstructions + call initialize_remapping( remapCS, remapScheme, boundary_extrapolation=.false., answers_2018=answers_2018 ) ! Next we initialize the regridding package so that it knows about the target grid do j = js, je ; do i = is, ie diff --git a/src/parameterizations/vertical/MOM_ALE_sponge.F90 b/src/parameterizations/vertical/MOM_ALE_sponge.F90 index bdf422bec8..182da4cd24 100644 --- a/src/parameterizations/vertical/MOM_ALE_sponge.F90 +++ b/src/parameterizations/vertical/MOM_ALE_sponge.F90 @@ -159,6 +159,7 @@ subroutine initialize_ALE_sponge_fixed(Iresttime, G, param_file, CS, data_h, nz_ real, allocatable, dimension(:,:) :: Iresttime_u !< inverse of the restoring time at u points [s-1] real, allocatable, dimension(:,:) :: Iresttime_v !< inverse of the restoring time at v points [s-1] logical :: bndExtrapolation = .true. ! If true, extrapolate boundaries + logical :: answers_2018, default_2018_answers integer :: i, j, k, col, total_sponge_cols, total_sponge_cols_u, total_sponge_cols_v character(len=10) :: remapScheme if (associated(CS)) then @@ -193,6 +194,13 @@ subroutine initialize_ALE_sponge_fixed(Iresttime, G, param_file, CS, data_h, nz_ "than PCM. E.g., if PPM is used for remapping, a "//& "PPM reconstruction will also be used within boundary cells.", & default=.false., do_not_log=.true.) + call get_param(param_file, mdl, "DEFAULT_2018_ANSWERS", default_2018_answers, & + "This sets the default value for the various _2018_ANSWERS parameters.", & + default=.true.) + call get_param(param_file, mdl, "REMAPPING_2018_ANSWERS", answers_2018, & + "If true, use the order of arithmetic and expressions that recover the "//& + "answers from the end of 2018. Otherwise, use updated and more robust "//& + "forms of the same expressions.", default=default_2018_answers) CS%time_varying_sponges = .false. CS%nz = G%ke @@ -232,7 +240,8 @@ subroutine initialize_ALE_sponge_fixed(Iresttime, G, param_file, CS, data_h, nz_ call sum_across_PEs(total_sponge_cols) ! Call the constructor for remapping control structure - call initialize_remapping(CS%remap_cs, remapScheme, boundary_extrapolation=bndExtrapolation) + call initialize_remapping(CS%remap_cs, remapScheme, boundary_extrapolation=bndExtrapolation, & + answers_2018=answers_2018) call log_param(param_file, mdl, "!Total sponge columns at h points", total_sponge_cols, & "The total number of columns where sponges are applied at h points.") @@ -388,6 +397,7 @@ subroutine initialize_ALE_sponge_varying(Iresttime, G, param_file, CS) real, allocatable, dimension(:,:) :: Iresttime_u !< inverse of the restoring time at u points [s-1] real, allocatable, dimension(:,:) :: Iresttime_v !< inverse of the restoring time at v points [s-1] logical :: bndExtrapolation = .true. ! If true, extrapolate boundaries + logical :: answers_2018, default_2018_answers logical :: spongeDataOngrid = .false. integer :: i, j, k, col, total_sponge_cols, total_sponge_cols_u, total_sponge_cols_v character(len=10) :: remapScheme @@ -418,6 +428,13 @@ subroutine initialize_ALE_sponge_varying(Iresttime, G, param_file, CS) "than PCM. E.g., if PPM is used for remapping, a "//& "PPM reconstruction will also be used within boundary cells.", & default=.false., do_not_log=.true.) + call get_param(param_file, mdl, "DEFAULT_2018_ANSWERS", default_2018_answers, & + "This sets the default value for the various _2018_ANSWERS parameters.", & + default=.true.) + call get_param(param_file, mdl, "REMAPPING_2018_ANSWERS", answers_2018, & + "If true, use the order of arithmetic and expressions that recover the "//& + "answers from the end of 2018. Otherwise, use updated and more robust "//& + "forms of the same expressions.", default=default_2018_answers) call get_param(param_file, mdl, "SPONGE_DATA_ONGRID", CS%spongeDataOngrid, & "When defined, the incoming sponge data are "//& "assumed to be on the model grid " , & @@ -452,7 +469,8 @@ subroutine initialize_ALE_sponge_varying(Iresttime, G, param_file, CS) call sum_across_PEs(total_sponge_cols) ! Call the constructor for remapping control structure - call initialize_remapping(CS%remap_cs, remapScheme, boundary_extrapolation=bndExtrapolation) + call initialize_remapping(CS%remap_cs, remapScheme, boundary_extrapolation=bndExtrapolation, & + answers_2018=answers_2018) call log_param(param_file, mdl, "!Total sponge columns at h points", total_sponge_cols, & "The total number of columns where sponges are applied at h points.") if (CS%sponge_uv) then diff --git a/src/parameterizations/vertical/MOM_tidal_mixing.F90 b/src/parameterizations/vertical/MOM_tidal_mixing.F90 index 887cc6d067..f60c54be6a 100644 --- a/src/parameterizations/vertical/MOM_tidal_mixing.F90 +++ b/src/parameterizations/vertical/MOM_tidal_mixing.F90 @@ -735,7 +735,6 @@ subroutine calculate_CVMix_tidal(h, j, G, GV, US, CS, N2_int, Kd_lay, Kv) 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 :: h_neglect, h_neglect_edge type(tidal_mixing_diags), pointer :: dd => NULL() is = G%isc ; ie = G%iec @@ -824,12 +823,6 @@ subroutine calculate_CVMix_tidal(h, j, G, GV, US, CS, N2_int, Kd_lay, Kv) ! and CVMix_compute_SchmittnerCoeff low subroutines allocate(exp_hab_zetar(G%ke+1,G%ke+1)) - 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 - do i=is,ie diff --git a/src/tracer/MOM_neutral_diffusion.F90 b/src/tracer/MOM_neutral_diffusion.F90 index 0ffff7409d..ed004acc1b 100644 --- a/src/tracer/MOM_neutral_diffusion.F90 +++ b/src/tracer/MOM_neutral_diffusion.F90 @@ -108,6 +108,7 @@ logical function neutral_diffusion_init(Time, G, param_file, diag, EOS, CS) ! Local variables character(len=256) :: mesg ! Message for error messages. character(len=80) :: string ! Temporary strings + logical :: answers_2018, default_2018_answers logical :: boundary_extrap if (associated(CS)) then @@ -144,7 +145,7 @@ logical function neutral_diffusion_init(Time, G, param_file, diag, EOS, CS) "pressure is used.", & default = -1.) ! Initialize and configure remapping - if (CS%continuous_reconstruction .eqv. .false.) then + if ( .not.CS%continuous_reconstruction ) then call get_param(param_file, mdl, "NDIFF_BOUNDARY_EXTRAP", boundary_extrap, & "Extrapolate at the top and bottommost cells, otherwise \n"// & "assume boundaries are piecewise constant", & @@ -154,7 +155,15 @@ logical function neutral_diffusion_init(Time, G, param_file, diag, EOS, CS) "for vertical remapping for all variables. "//& "It can be one of the following schemes: "//& trim(remappingSchemesDoc), default=remappingDefaultScheme) - call initialize_remapping( CS%remap_CS, string, boundary_extrapolation = boundary_extrap ) + call get_param(param_file, mdl, "DEFAULT_2018_ANSWERS", default_2018_answers, & + "This sets the default value for the various _2018_ANSWERS parameters.", & + default=.true.) + call get_param(param_file, mdl, "REMAPPING_2018_ANSWERS", answers_2018, & + "If true, use the order of arithmetic and expressions that recover the "//& + "answers from the end of 2018. Otherwise, use updated and more robust "//& + "forms of the same expressions.", default=default_2018_answers) + call initialize_remapping( CS%remap_CS, string, boundary_extrapolation=boundary_extrap, & + answers_2018=answers_2018 ) call extract_member_remapping_CS(CS%remap_CS, degree=CS%deg) call get_param(param_file, mdl, "NEUTRAL_POS_METHOD", CS%neutral_pos_method, & "Method used to find the neutral position \n"// & From 60d9e7fe6d55919b9bc0569af78adfcaf8714d20 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 18 Dec 2019 17:08:05 -0500 Subject: [PATCH 012/316] +(*)Set h_neglect_edge to GV%H_subroundoff Set h_neglect_edge to GV%H_subroundoff when REMAPPING_2018_ANSWERS is false, eliminating an arbitrary, hard-coded and sometimes inappropriate not-very-small dimensional constant. This change required the addition of some new optional arguments to some routines, including set_regrid_params, ALE_remap_scalar and wave_speed_set_param. By default all answers are bitwise identical in the MOM6-examples test cases, but they do change slightly when REMAPPING_2018_ANSWERS is false. --- src/ALE/MOM_ALE.F90 | 42 ++++++++----- src/ALE/MOM_regridding.F90 | 35 ++++++++--- src/ALE/MOM_remapping.F90 | 6 +- src/ALE/P3M_functions.F90 | 3 +- src/diagnostics/MOM_diagnostics.F90 | 10 +++- src/diagnostics/MOM_wave_speed.F90 | 36 ++++++++--- src/framework/MOM_diag_remap.F90 | 13 ++-- .../MOM_state_initialization.F90 | 37 +++++++++--- .../MOM_tracer_initialization_from_Z.F90 | 2 +- .../lateral/MOM_lateral_mixing_coeffs.F90 | 11 +++- .../vertical/MOM_ALE_sponge.F90 | 19 +++--- .../vertical/MOM_tidal_mixing.F90 | 10 +++- src/tracer/MOM_neutral_diffusion.F90 | 59 +++++++++---------- 13 files changed, 193 insertions(+), 90 deletions(-) diff --git a/src/ALE/MOM_ALE.F90 b/src/ALE/MOM_ALE.F90 index c6b68bf646..5f0c8839b9 100644 --- a/src/ALE/MOM_ALE.F90 +++ b/src/ALE/MOM_ALE.F90 @@ -522,8 +522,8 @@ subroutine ALE_offline_inputs(CS, G, GV, h, tv, Reg, uhtr, vhtr, Kd, debug, OBC) endif 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) + call ALE_remap_scalar(CS%remapCS, G, GV, nk, h, tv%T, h_new, tv%T, answers_2018=CS%answers_2018) + call ALE_remap_scalar(CS%remapCS, G, GV, nk, h, tv%S, h_new, tv%S, answers_2018=CS%answers_2018) if (debug) call MOM_tracer_chkinv("After ALE_offline_inputs", G, h_new, Reg%Tr, Reg%ntr) @@ -787,8 +787,9 @@ subroutine remap_all_state_vars(CS_remapping, CS_ALE, G, GV, h_old, h_new, Reg, "and u/v are to be remapped") endif - !### Try replacing both of these with GV%H_subroundoff - if (GV%Boussinesq) then + if (.not.CS_ALE%answers_2018) then + h_neglect = GV%H_subroundoff ; h_neglect_edge = GV%H_subroundoff + elseif (GV%Boussinesq) then h_neglect = GV%m_to_H*1.0e-30 ; h_neglect_edge = GV%m_to_H*1.0e-10 else h_neglect = GV%kg_m2_to_H*1.0e-30 ; h_neglect_edge = GV%kg_m2_to_H*1.0e-10 @@ -939,7 +940,7 @@ end subroutine remap_all_state_vars !> Remaps a single scalar between grids described by thicknesses h_src and h_dst. !! h_dst must be dimensioned as a model array with GV%ke layers while h_src can !! have an arbitrary number of layers specified by nk_src. -subroutine ALE_remap_scalar(CS, G, GV, nk_src, h_src, s_src, h_dst, s_dst, all_cells, old_remap ) +subroutine ALE_remap_scalar(CS, G, GV, nk_src, h_src, s_src, h_dst, s_dst, all_cells, old_remap, answers_2018 ) type(remapping_CS), intent(in) :: CS !< Remapping control structure type(ocean_grid_type), intent(in) :: G !< Ocean grid structure type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure @@ -955,20 +956,26 @@ subroutine ALE_remap_scalar(CS, G, GV, nk_src, h_src, s_src, h_dst, s_dst, all_c !! layers otherwise (default). logical, optional, intent(in) :: old_remap !< If true, use the old "remapping_core_w" !! method, otherwise use "remapping_core_h". + logical, optional, intent(in) :: answers_2018 !< If true, use the order of arithmetic + !! and expressions that recover the answers for + !! remapping from the end of 2018. Otherwise, + !! use more robust forms of the same expressions. ! Local variables integer :: i, j, k, n_points real :: dx(GV%ke+1) real :: h_neglect, h_neglect_edge - logical :: ignore_vanished_layers, use_remapping_core_w + logical :: ignore_vanished_layers, use_remapping_core_w, use_2018_remap ignore_vanished_layers = .false. if (present(all_cells)) ignore_vanished_layers = .not. all_cells use_remapping_core_w = .false. if (present(old_remap)) use_remapping_core_w = old_remap n_points = nk_src + use_2018_remap = .true. ; if (present(answers_2018)) use_2018_remap = answers_2018 - !### Try replacing both of these with GV%H_subroundoff - if (GV%Boussinesq) then + if (.not.use_2018_remap) then + h_neglect = GV%H_subroundoff ; h_neglect_edge = GV%H_subroundoff + elseif (GV%Boussinesq) then h_neglect = GV%m_to_H*1.0e-30 ; h_neglect_edge = GV%m_to_H*1.0e-10 else h_neglect = GV%kg_m2_to_H*1.0e-30 ; h_neglect_edge = GV%kg_m2_to_H*1.0e-10 @@ -1031,8 +1038,9 @@ subroutine pressure_gradient_plm( CS, S_t, S_b, T_t, T_b, G, GV, tv, h, bdry_ext real, dimension(CS%nk,2) :: ppol_coefs !Coefficients of polynomial real :: h_neglect - !### Replace this with GV%H_subroundoff - if (GV%Boussinesq) then + if (.not.CS%answers_2018) then + h_neglect = GV%H_subroundoff + elseif (GV%Boussinesq) then h_neglect = GV%m_to_H*1.0e-30 else h_neglect = GV%kg_m2_to_H*1.0e-30 @@ -1107,8 +1115,9 @@ subroutine pressure_gradient_ppm( CS, S_t, S_b, T_t, T_b, G, GV, tv, h, bdry_ext ppol_coefs ! Coefficients of polynomial, all in [degC] or [ppt] real :: h_neglect, h_neglect_edge ! Tiny thicknesses [H ~> m or kg m-2] - !### Try replacing both of these with GV%H_subroundoff - if (GV%Boussinesq) then + if (.not.CS%answers_2018) then + h_neglect = GV%H_subroundoff ; h_neglect_edge = GV%H_subroundoff + elseif (GV%Boussinesq) then h_neglect = GV%m_to_H*1.0e-30 ; h_neglect_edge = GV%m_to_H*1.0e-10 else h_neglect = GV%kg_m2_to_H*1.0e-30 ; h_neglect_edge = GV%kg_m2_to_H*1.0e-10 @@ -1125,7 +1134,6 @@ subroutine pressure_gradient_ppm( CS, S_t, S_b, T_t, T_b, G, GV, tv, h, bdry_ext ! 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, & answers_2018=CS%answers_2018 ) call PPM_reconstruction( GV%ke, hTmp, tmp, ppol_E, ppol_coefs, h_neglect, & @@ -1142,9 +1150,13 @@ subroutine pressure_gradient_ppm( CS, S_t, S_b, T_t, T_b, G, GV, tv, h, bdry_ext 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, & + if (CS%answers_2018) then + call edge_values_implicit_h4( GV%ke, hTmp, tmp, ppol_E, h_neglect=1.0e-10*GV%m_to_H, & answers_2018=CS%answers_2018 ) + else + call edge_values_implicit_h4( GV%ke, hTmp, tmp, ppol_E, h_neglect=GV%H_subroundoff, & + answers_2018=CS%answers_2018 ) + endif call PPM_reconstruction( GV%ke, hTmp, tmp, ppol_E, ppol_coefs, h_neglect, & answers_2018=CS%answers_2018 ) if (bdry_extrap) & diff --git a/src/ALE/MOM_regridding.F90 b/src/ALE/MOM_regridding.F90 index 0cb012b208..423cc65687 100644 --- a/src/ALE/MOM_regridding.F90 +++ b/src/ALE/MOM_regridding.F90 @@ -115,6 +115,10 @@ module MOM_regridding !! If false, integrate from the bottom upward, as does the rest of the model. logical :: integrate_downward_for_e = .true. + !> If true, use the order of arithmetic and expressions that recover the remapping answers from 2018. + !! If false, use more robust forms of the same remapping expressions. + logical :: remap_answers_2018 = .true. + type(zlike_CS), pointer :: zlike_CS => null() !< Control structure for z-like coordinate generator type(sigma_CS), pointer :: sigma_CS => null() !< Control structure for sigma coordinate generator type(rho_CS), pointer :: rho_CS => null() !< Control structure for rho coordinate generator @@ -194,6 +198,7 @@ subroutine initialize_regridding(CS, GV, US, max_depth, param_file, mdl, coord_m character(len=12) :: expected_units ! Temporary strings logical :: tmpLogical, fix_haloclines, set_max, do_sum, main_parameters logical :: coord_is_state_dependent, ierr + logical :: default_2018_answers, remap_answers_2018 real :: filt_len, strat_tol, index_scale, tmpReal real :: maximum_depth ! The maximum depth of the ocean [m] (not in Z). real :: dz_fixed_sfc, Rho_avg_depth, nlay_sfc_int @@ -251,6 +256,15 @@ subroutine initialize_regridding(CS, GV, US, max_depth, param_file, mdl, coord_m "used. It can be one of the following schemes: "//& trim(regriddingInterpSchemeDoc), default=trim(string2)) call set_regrid_params(CS, interp_scheme=string) + + call get_param(param_file, mdl, "DEFAULT_2018_ANSWERS", default_2018_answers, & + "This sets the default value for the various _2018_ANSWERS parameters.", & + default=.true.) + call get_param(param_file, mdl, "REMAPPING_2018_ANSWERS", remap_answers_2018, & + "If true, use the order of arithmetic and expressions that recover the "//& + "answers from the end of 2018. Otherwise, use updated and more robust "//& + "forms of the same expressions.", default=default_2018_answers) + call set_regrid_params(CS, remap_answers_2018=remap_answers_2018) endif if (main_parameters .and. coord_is_state_dependent) then @@ -1343,8 +1357,9 @@ subroutine build_rho_grid( G, GV, h, tv, dzInterface, remapCS, CS ) real :: dh #endif - !### Try replacing both of these with GV%H_subroundoff - if (GV%Boussinesq) then + if (.not.CS%remap_answers_2018) then + h_neglect = GV%H_subroundoff ; h_neglect_edge = GV%H_subroundoff + elseif (GV%Boussinesq) then h_neglect = GV%m_to_H*1.0e-30 ; h_neglect_edge = GV%m_to_H*1.0e-10 else h_neglect = GV%kg_m2_to_H*1.0e-30 ; h_neglect_edge = GV%kg_m2_to_H*1.0e-10 @@ -1455,8 +1470,9 @@ subroutine build_grid_HyCOM1( G, GV, h, tv, h_new, dzInterface, CS ) real :: depth real :: h_neglect, h_neglect_edge - !### Try replacing both of these with GV%H_subroundoff - if (GV%Boussinesq) then + if (.not.CS%remap_answers_2018) then + h_neglect = GV%H_subroundoff ; h_neglect_edge = GV%H_subroundoff + elseif (GV%Boussinesq) then h_neglect = GV%m_to_H*1.0e-30 ; h_neglect_edge = GV%m_to_H*1.0e-10 else h_neglect = GV%kg_m2_to_H*1.0e-30 ; h_neglect_edge = GV%kg_m2_to_H*1.0e-10 @@ -1588,8 +1604,9 @@ subroutine build_grid_SLight(G, GV, h, tv, dzInterface, CS) integer :: i, j, k, nz real :: h_neglect, h_neglect_edge - !### Try replacing both of these with GV%H_subroundoff - if (GV%Boussinesq) then + if (.not.CS%remap_answers_2018) then + h_neglect = GV%H_subroundoff ; h_neglect_edge = GV%H_subroundoff + elseif (GV%Boussinesq) then h_neglect = GV%m_to_H*1.0e-30 ; h_neglect_edge = GV%m_to_H*1.0e-10 else h_neglect = GV%kg_m2_to_H*1.0e-30 ; h_neglect_edge = GV%kg_m2_to_H*1.0e-10 @@ -2213,7 +2230,7 @@ subroutine set_regrid_params( CS, boundary_extrapolation, min_thickness, old_gri interp_scheme, depth_of_time_filter_shallow, depth_of_time_filter_deep, & compress_fraction, dz_min_surface, nz_fixed_surface, Rho_ML_avg_depth, & nlay_ML_to_interior, fix_haloclines, halocline_filt_len, & - halocline_strat_tol, integrate_downward_for_e, & + halocline_strat_tol, integrate_downward_for_e, remap_answers_2018, & 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 @@ -2238,6 +2255,9 @@ subroutine set_regrid_params( CS, boundary_extrapolation, min_thickness, old_gri !! halocline region. logical, optional, intent(in) :: integrate_downward_for_e !< If true, integrate for interface positions downward !! from the top. + logical, optional, intent(in) :: remap_answers_2018 !< If true, use the order of arithmetic and expressions + !! that recover the remapping answers from 2018. Otherwise + !! use more robust but mathematically equivalent expressions. real, optional, intent(in) :: adaptTimeRatio !< Ratio of the ALE timestep to the grid timescale [nondim]. real, optional, intent(in) :: adaptZoom !< Depth of near-surface zooming region [H ~> m or kg m-2]. real, optional, intent(in) :: adaptZoomCoeff !< Coefficient of near-surface zooming diffusivity [nondim]. @@ -2265,6 +2285,7 @@ subroutine set_regrid_params( CS, boundary_extrapolation, min_thickness, old_gri if (present(min_thickness)) CS%min_thickness = min_thickness if (present(compress_fraction)) CS%compressibility_fraction = compress_fraction if (present(integrate_downward_for_e)) CS%integrate_downward_for_e = integrate_downward_for_e + if (present(remap_answers_2018)) CS%remap_answers_2018 = remap_answers_2018 select case (CS%regridding_scheme) case (REGRIDDING_ZSTAR) diff --git a/src/ALE/MOM_remapping.F90 b/src/ALE/MOM_remapping.F90 index 5b91eba045..5c2bc9918c 100644 --- a/src/ALE/MOM_remapping.F90 +++ b/src/ALE/MOM_remapping.F90 @@ -184,7 +184,7 @@ function isPosSumErrSignificant(n1, sum1, n2, sum2) end function isPosSumErrSignificant !> Remaps column of values u0 on grid h0 to grid h1 assuming the top edge is aligned. -subroutine remapping_core_h(CS, n0, h0, u0, n1, h1, u1, h_neglect, h_neglect_edge) +subroutine remapping_core_h(CS, n0, h0, u0, n1, h1, u1, h_neglect, h_neglect_edge) 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 @@ -1630,9 +1630,9 @@ logical function remapping_unit_tests(verbose) logical :: thisTest, v v = verbose - h_neglect = hNeglect_dflt - h_neglect_edge = 1.0e-10 answers_2018 = .false. ! .true. + h_neglect = hNeglect_dflt + h_neglect_edge = hNeglect_dflt ; if (answers_2018) h_neglect_edge = 1.0e-10 write(*,*) '==== MOM_remapping: remapping_unit_tests =================' remapping_unit_tests = .false. ! Normally return false diff --git a/src/ALE/P3M_functions.F90 b/src/ALE/P3M_functions.F90 index 3ea756b7c3..434668894b 100644 --- a/src/ALE/P3M_functions.F90 +++ b/src/ALE/P3M_functions.F90 @@ -212,8 +212,7 @@ subroutine P3M_boundary_extrapolation( N, h, u, ppoly_E, ppoly_S, ppoly_coef, & real :: hNeglect, hNeglect_edge ! Negligibly small thickness [H] hNeglect = hNeglect_dflt ; if (present(h_neglect)) hNeglect = h_neglect - hNeglect_edge = hNeglect_edge_dflt - if (present(h_neglect_edge)) hNeglect_edge = h_neglect_edge + hNeglect_edge = hNeglect_edge_dflt ; if (present(h_neglect_edge)) hNeglect_edge = h_neglect_edge ! ----- Left boundary ----- i0 = 1 diff --git a/src/diagnostics/MOM_diagnostics.F90 b/src/diagnostics/MOM_diagnostics.F90 index 95c3ad6916..4caabf94a6 100644 --- a/src/diagnostics/MOM_diagnostics.F90 +++ b/src/diagnostics/MOM_diagnostics.F90 @@ -1446,6 +1446,7 @@ subroutine MOM_diagnostics_init(MIS, ADp, CDp, Time, G, GV, US, param_file, diag character(len=40) :: mdl = "MOM_diagnostics" ! This module's name. character(len=48) :: thickness_units, flux_units logical :: use_temperature, adiabatic + logical :: default_2018_answers, remap_answers_2018 integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB, nz, nkml, nkbl integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, i, j @@ -1476,6 +1477,13 @@ subroutine MOM_diagnostics_init(MIS, ADp, CDp, Time, G, GV, US, param_file, diag "The depth below which N2 is limited as monotonic for the "// & "purposes of calculating the equivalent barotropic wave speed.", & units='m', scale=US%m_to_Z, default=-1.) + call get_param(param_file, mdl, "DEFAULT_2018_ANSWERS", default_2018_answers, & + "This sets the default value for the various _2018_ANSWERS parameters.", & + default=.true.) + call get_param(param_file, mdl, "REMAPPING_2018_ANSWERS", remap_answers_2018, & + "If true, use the order of arithmetic and expressions that recover the "//& + "answers from the end of 2018. Otherwise, use updated and more robust "//& + "forms of the same expressions.", default=default_2018_answers) if (GV%Boussinesq) then thickness_units = "m" ; flux_units = "m3 s-1" ; convert_H = GV%H_to_m @@ -1686,7 +1694,7 @@ subroutine MOM_diagnostics_init(MIS, ADp, CDp, Time, G, GV, US, param_file, diag if ((CS%id_cg1>0) .or. (CS%id_Rd1>0) .or. (CS%id_cfl_cg1>0) .or. & (CS%id_cfl_cg1_x>0) .or. (CS%id_cfl_cg1_y>0) .or. & (CS%id_cg_ebt>0) .or. (CS%id_Rd_ebt>0) .or. (CS%id_p_ebt>0)) then - call wave_speed_init(CS%wave_speed_CSp) + call wave_speed_init(CS%wave_speed_CSp, remap_answers_2018=remap_answers_2018) call safe_alloc_ptr(CS%cg1,isd,ied,jsd,jed) if (CS%id_Rd1>0) call safe_alloc_ptr(CS%Rd1,isd,ied,jsd,jed) if (CS%id_Rd_ebt>0) call safe_alloc_ptr(CS%Rd1,isd,ied,jsd,jed) diff --git a/src/diagnostics/MOM_wave_speed.F90 b/src/diagnostics/MOM_wave_speed.F90 index eb11a2b5e9..376d0f36b2 100644 --- a/src/diagnostics/MOM_wave_speed.F90 +++ b/src/diagnostics/MOM_wave_speed.F90 @@ -40,6 +40,9 @@ module MOM_wave_speed !! can be overridden by optional arguments. type(remapping_CS) :: remapping_CS !< Used for vertical remapping when calculating equivalent barotropic !! mode structure. + logical :: remap_answers_2018 = .true. !> If true, use the order of arithmetic and expressions that + !! recover the remapping answers from 2018. If false, use more + !! robust forms of the same remapping expressions. type(diag_ctrl), pointer :: diag !< Diagnostics control structure end type wave_speed_CS @@ -492,9 +495,15 @@ subroutine wave_speed(h, tv, G, GV, US, cg1, CS, full_halos, use_ebt_mode, & do k = 1,kc Hc_H(k) = GV%Z_to_H * Hc(k) enddo - call remapping_core_h(CS%remapping_CS, kc, Hc_H(:), mode_struct, & - nz, h(i,j,:), modal_structure(i,j,:), & - 1.0e-30*GV%m_to_H, 1.0e-10*GV%m_to_H) + if (CS%remap_answers_2018) then + call remapping_core_h(CS%remapping_CS, kc, Hc_H(:), mode_struct, & + nz, h(i,j,:), modal_structure(i,j,:), & + 1.0e-30*GV%m_to_H, 1.0e-10*GV%m_to_H) + else + call remapping_core_h(CS%remapping_CS, kc, Hc_H(:), mode_struct, & + nz, h(i,j,:), modal_structure(i,j,:), & + GV%H_subroundoff, GV%H_subroundoff) + endif endif else cg1(i,j) = 0.0 @@ -1057,7 +1066,7 @@ subroutine tridiag_det(a, b, c, nrows, lam, det_out, ddet_out, row_scale) end subroutine tridiag_det !> Initialize control structure for MOM_wave_speed -subroutine wave_speed_init(CS, use_ebt_mode, mono_N2_column_fraction, mono_N2_depth) +subroutine wave_speed_init(CS, use_ebt_mode, mono_N2_column_fraction, mono_N2_depth, remap_answers_2018) 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. @@ -1067,8 +1076,13 @@ subroutine wave_speed_init(CS, use_ebt_mode, mono_N2_column_fraction, mono_N2_de real, optional, intent(in) :: mono_N2_depth !< The depth below which N2 is limited !! as monotonic for the purposes of calculating the !! vertical modal structure [Z ~> m]. -! This include declares and sets the variable "version". -#include "version_variable.h" + logical, optional, intent(in) :: remap_answers_2018 !< If true, use the order of arithmetic and expressions + !! that recover the remapping answers from 2018. Otherwise + !! use more robust but mathematically equivalent expressions. + + + ! This include declares and sets the variable "version". +# include "version_variable.h" character(len=40) :: mdl = "MOM_wave_speed" ! This module's name. if (associated(CS)) then @@ -1082,12 +1096,13 @@ subroutine wave_speed_init(CS, use_ebt_mode, mono_N2_column_fraction, mono_N2_de call wave_speed_set_param(CS, use_ebt_mode=use_ebt_mode, mono_N2_column_fraction=mono_N2_column_fraction) - call initialize_remapping(CS%remapping_CS, 'PLM', boundary_extrapolation=.false.) + call initialize_remapping(CS%remapping_CS, 'PLM', boundary_extrapolation=.false., & + answers_2018=CS%remap_answers_2018) end subroutine wave_speed_init !> Sets internal parameters for MOM_wave_speed -subroutine wave_speed_set_param(CS, use_ebt_mode, mono_N2_column_fraction, mono_N2_depth) +subroutine wave_speed_set_param(CS, use_ebt_mode, mono_N2_column_fraction, mono_N2_depth, remap_answers_2018) 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. @@ -1097,6 +1112,9 @@ subroutine wave_speed_set_param(CS, use_ebt_mode, mono_N2_column_fraction, mono_ real, optional, intent(in) :: mono_N2_depth !< The depth below which N2 is limited !! as monotonic for the purposes of calculating the !! vertical modal structure [Z ~> m]. + logical, optional, intent(in) :: remap_answers_2018 !< If true, use the order of arithmetic and expressions + !! that recover the remapping answers from 2018. Otherwise + !! use more robust but mathematically equivalent expressions. if (.not.associated(CS)) call MOM_error(FATAL, & "wave_speed_set_param called with an associated control structure.") @@ -1104,10 +1122,12 @@ subroutine wave_speed_set_param(CS, use_ebt_mode, mono_N2_column_fraction, mono_ if (present(use_ebt_mode)) CS%use_ebt_mode = use_ebt_mode if (present(mono_N2_column_fraction)) CS%mono_N2_column_fraction = mono_N2_column_fraction if (present(mono_N2_depth)) CS%mono_N2_depth = mono_N2_depth + if (present(remap_answers_2018)) CS%remap_answers_2018 = remap_answers_2018 end subroutine wave_speed_set_param !> \namespace mom_wave_speed + !! !! Subroutine wave_speed() solves for the first baroclinic mode wave speed. (It could !! solve for all the wave speeds, but the iterative approach taken here means diff --git a/src/framework/MOM_diag_remap.F90 b/src/framework/MOM_diag_remap.F90 index 8855af9caa..b61c10eb7e 100644 --- a/src/framework/MOM_diag_remap.F90 +++ b/src/framework/MOM_diag_remap.F90 @@ -292,8 +292,9 @@ subroutine diag_remap_update(remap_cs, G, GV, US, h, T, S, eqn_of_state) return endif - !### Try replacing both of these with GV%H_subroundoff - if (GV%Boussinesq) then + if (.not.remap_cs%answers_2018) then + h_neglect = GV%H_subroundoff ; h_neglect_edge = GV%H_subroundoff + elseif (GV%Boussinesq) then h_neglect = GV%m_to_H*1.0e-30 ; h_neglect_edge = GV%m_to_H*1.0e-10 else h_neglect = GV%kg_m2_to_H*1.0e-30 ; h_neglect_edge = GV%kg_m2_to_H*1.0e-10 @@ -369,11 +370,9 @@ subroutine diag_remap_do_remap(remap_cs, G, GV, h, staggered_in_x, staggered_in_ call assert(size(field, 3) == size(h, 3), & 'diag_remap_do_remap: Remap field and thickness z-axes do not match.') - !### Try replacing both of these with GV%H_subroundoff - ! if (remap_cs%answers_2018) then - ! h_neglect = GV%H_subroundoff ; h_neglect_edge = GV%H_subroundoff - ! elseif (GV%Boussinesq) then - if (GV%Boussinesq) then + if (.not.remap_cs%answers_2018) then + h_neglect = GV%H_subroundoff ; h_neglect_edge = GV%H_subroundoff + elseif (GV%Boussinesq) then h_neglect = GV%m_to_H*1.0e-30 ; h_neglect_edge = GV%m_to_H*1.0e-10 else h_neglect = GV%kg_m2_to_H*1.0e-30 ; h_neglect_edge = GV%kg_m2_to_H*1.0e-10 diff --git a/src/initialization/MOM_state_initialization.F90 b/src/initialization/MOM_state_initialization.F90 index c370cece88..1c57c2bcb6 100644 --- a/src/initialization/MOM_state_initialization.F90 +++ b/src/initialization/MOM_state_initialization.F90 @@ -1105,6 +1105,7 @@ subroutine trim_for_ice(PF, G, GV, US, ALE_CSp, tv, h, just_read_params) real :: scale_factor ! A file-dependent scaling vactor for the input pressurs. real :: min_thickness ! The minimum layer thickness, recast into Z units. integer :: i, j, k + logical :: default_2018_answers, remap_answers_2018 logical :: just_read ! If true, just read parameters but set nothing. logical :: use_remapping ! If true, remap the initial conditions. type(remapping_CS), pointer :: remap_CS => NULL() @@ -1130,6 +1131,16 @@ subroutine trim_for_ice(PF, G, GV, US, ALE_CSp, tv, h, just_read_params) call get_param(PF, mdl, "TRIMMING_USES_REMAPPING", use_remapping, & 'When trimming the column, also remap T and S.', & default=.false., do_not_log=just_read) + remap_answers_2018 = .true. + if (use_remapping) then + call get_param(PF, mdl, "DEFAULT_2018_ANSWERS", default_2018_answers, & + "This sets the default value for the various _2018_ANSWERS parameters.", & + default=.true.) + call get_param(PF, mdl, "REMAPPING_2018_ANSWERS", remap_answers_2018, & + "If true, use the order of arithmetic and expressions that recover the "//& + "answers from the end of 2018. Otherwise, use updated and more robust "//& + "forms of the same expressions.", default=default_2018_answers) + endif if (just_read) return ! All run-time parameters have been read, so return. @@ -1155,7 +1166,7 @@ subroutine trim_for_ice(PF, G, GV, US, ALE_CSp, tv, h, just_read_params) call cut_off_column_top(GV%ke, tv, GV, US, GV%mks_g_Earth*US%Z_to_m, G%bathyT(i,j), & min_thickness, tv%T(i,j,:), T_t(i,j,:), T_b(i,j,:), & tv%S(i,j,:), S_t(i,j,:), S_b(i,j,:), p_surf(i,j), h(i,j,:), remap_CS, & - z_tol=1.0e-5*US%m_to_Z) + z_tol=1.0e-5*US%m_to_Z, remap_answers_2018=remap_answers_2018) enddo ; enddo end subroutine trim_for_ice @@ -1163,8 +1174,8 @@ end subroutine trim_for_ice !> Adjust the layer thicknesses by removing the top of the water column above the !! depth where the hydrostatic pressure matches p_surf -subroutine cut_off_column_top(nk, tv, GV, US, G_earth, depth, min_thickness, & - T, T_t, T_b, S, S_t, S_b, p_surf, h, remap_CS, z_tol) +subroutine cut_off_column_top(nk, tv, GV, US, G_earth, depth, min_thickness, T, T_t, T_b, & + S, S_t, S_b, p_surf, h, remap_CS, z_tol, remap_answers_2018) integer, intent(in) :: nk !< Number of layers type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamics structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. @@ -1184,13 +1195,20 @@ subroutine cut_off_column_top(nk, tv, GV, US, G_earth, depth, min_thickness, & !! if associated real, optional, intent(in) :: z_tol !< The tolerance with which to find the depth !! matching the specified pressure [Z ~> m]. + logical, optional, intent(in) :: remap_answers_2018 !< If true, use the order of arithmetic + !! and expressions that recover the answers for remapping + !! from the end of 2018. Otherwise, use more robust + !! forms of the same expressions. ! Local variables real, dimension(nk+1) :: e ! Top and bottom edge values for reconstructions real, dimension(nk) :: h0, S0, T0, h1, S1, T1 real :: P_t, P_b, z_out, e_top + logical :: answers_2018 integer :: k + answers_2018 = .true. ; if (present(remap_answers_2018)) answers_2018 = remap_answers_2018 + ! Calculate original interface positions e(nk+1) = -depth do k=nk,1,-1 @@ -1239,8 +1257,13 @@ subroutine cut_off_column_top(nk, tv, GV, US, G_earth, depth, min_thickness, & T0(k) = T(nk+1-k) h1(k) = h(nk+1-k) enddo - call remapping_core_h(remap_CS, nk, h0, T0, nk, h1, T1, 1.0e-30*GV%m_to_H, 1.0e-10*GV%m_to_H) - call remapping_core_h(remap_CS, nk, h0, S0, nk, h1, S1, 1.0e-30*GV%m_to_H, 1.0e-10*GV%m_to_H) + if (answers_2018) then + call remapping_core_h(remap_CS, nk, h0, T0, nk, h1, T1, 1.0e-30*GV%m_to_H, 1.0e-10*GV%m_to_H) + call remapping_core_h(remap_CS, nk, h0, S0, nk, h1, S1, 1.0e-30*GV%m_to_H, 1.0e-10*GV%m_to_H) + else + call remapping_core_h(remap_CS, nk, h0, T0, nk, h1, T1, GV%H_subroundoff, GV%H_subroundoff) + call remapping_core_h(remap_CS, nk, h0, S0, nk, h1, S1, GV%H_subroundoff, GV%H_subroundoff) + endif do k=1,nk S(k) = S1(nk+1-k) T(k) = T1(nk+1-k) @@ -2284,9 +2307,9 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, G, GV, US, PF, just_read_param deallocate( dz_interface ) endif call ALE_remap_scalar(remapCS, G, GV, nkd, h1, tmpT1dIn, h, tv%T, all_cells=remap_full_column, & - old_remap=remap_old_alg ) + old_remap=remap_old_alg, answers_2018=answers_2018 ) call ALE_remap_scalar(remapCS, G, GV, nkd, h1, tmpS1dIn, h, tv%S, all_cells=remap_full_column, & - old_remap=remap_old_alg ) + old_remap=remap_old_alg, answers_2018=answers_2018 ) deallocate( h1 ) deallocate( tmpT1dIn ) deallocate( tmpS1dIn ) diff --git a/src/initialization/MOM_tracer_initialization_from_Z.F90 b/src/initialization/MOM_tracer_initialization_from_Z.F90 index 553a25379e..bbe61892b2 100644 --- a/src/initialization/MOM_tracer_initialization_from_Z.F90 +++ b/src/initialization/MOM_tracer_initialization_from_Z.F90 @@ -176,7 +176,7 @@ subroutine MOM_initialize_tracer_from_Z(h, tr, G, GV, US, PF, src_file, src_var_ hSrc(i,j,:) = GV%Z_to_H * h1(:) enddo ; enddo - call ALE_remap_scalar(remapCS, G, GV, kd, hSrc, tr_z, h, tr, all_cells=.false. ) + call ALE_remap_scalar(remapCS, G, GV, kd, hSrc, tr_z, h, tr, all_cells=.false., answers_2018=answers_2018 ) deallocate( hSrc ) deallocate( h1 ) diff --git a/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 b/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 index 710012c837..a25b810846 100644 --- a/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 +++ b/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 @@ -877,6 +877,7 @@ subroutine VarMix_init(Time, G, GV, US, param_file, diag, CS) real :: absurdly_small_freq ! A miniscule frequency that is used to avoid division by 0 [T-1 ~> s-1]. The ! default value is roughly (pi / (the age of the universe)). logical :: Gill_equatorial_Ld, use_FGNV_streamfn, use_MEKE, in_use + logical :: default_2018_answers, remap_answers_2018 real :: MLE_front_length real :: Leith_Lap_const ! The non-dimensional coefficient in the Leith viscosity real :: grid_sp_u2, grid_sp_v2 ! Intermediate quantities for Leith metrics [L2 ~> m2] @@ -1178,7 +1179,15 @@ subroutine VarMix_init(Time, G, GV, US, param_file, diag, CS) if (CS%calculate_cg1) then in_use = .true. allocate(CS%cg1(isd:ied,jsd:jed)) ; CS%cg1(:,:) = 0.0 - call wave_speed_init(CS%wave_speed_CSp, use_ebt_mode=CS%Resoln_use_ebt, mono_N2_depth=N2_filter_depth) + call get_param(param_file, mdl, "DEFAULT_2018_ANSWERS", default_2018_answers, & + "This sets the default value for the various _2018_ANSWERS parameters.", & + default=.true.) + call get_param(param_file, mdl, "REMAPPING_2018_ANSWERS", remap_answers_2018, & + "If true, use the order of arithmetic and expressions that recover the "//& + "answers from the end of 2018. Otherwise, use updated and more robust "//& + "forms of the same expressions.", default=default_2018_answers) + call wave_speed_init(CS%wave_speed_CSp, use_ebt_mode=CS%Resoln_use_ebt, & + mono_N2_depth=N2_filter_depth, remap_answers_2018=remap_answers_2018) endif ! Leith parameters diff --git a/src/parameterizations/vertical/MOM_ALE_sponge.F90 b/src/parameterizations/vertical/MOM_ALE_sponge.F90 index 182da4cd24..4fa4996b05 100644 --- a/src/parameterizations/vertical/MOM_ALE_sponge.F90 +++ b/src/parameterizations/vertical/MOM_ALE_sponge.F90 @@ -127,6 +127,9 @@ module MOM_ALE_sponge !! timing of diagnostic output. type(remapping_cs) :: remap_cs !< Remapping parameters and work arrays + logical :: remap_answers_2018 !< If true, use the order of arithmetic and expressions that + !! recover the answers for remapping from the end of 2018. + !! Otherwise, use more robust forms of the same expressions. logical :: time_varying_sponges !< True if using newer sponge code logical :: spongeDataOngrid !< True if the sponge data are on the model horizontal grid @@ -159,7 +162,7 @@ subroutine initialize_ALE_sponge_fixed(Iresttime, G, param_file, CS, data_h, nz_ real, allocatable, dimension(:,:) :: Iresttime_u !< inverse of the restoring time at u points [s-1] real, allocatable, dimension(:,:) :: Iresttime_v !< inverse of the restoring time at v points [s-1] logical :: bndExtrapolation = .true. ! If true, extrapolate boundaries - logical :: answers_2018, default_2018_answers + logical :: default_2018_answers integer :: i, j, k, col, total_sponge_cols, total_sponge_cols_u, total_sponge_cols_v character(len=10) :: remapScheme if (associated(CS)) then @@ -197,7 +200,7 @@ subroutine initialize_ALE_sponge_fixed(Iresttime, G, param_file, CS, data_h, nz_ call get_param(param_file, mdl, "DEFAULT_2018_ANSWERS", default_2018_answers, & "This sets the default value for the various _2018_ANSWERS parameters.", & default=.true.) - call get_param(param_file, mdl, "REMAPPING_2018_ANSWERS", answers_2018, & + call get_param(param_file, mdl, "REMAPPING_2018_ANSWERS", CS%remap_answers_2018, & "If true, use the order of arithmetic and expressions that recover the "//& "answers from the end of 2018. Otherwise, use updated and more robust "//& "forms of the same expressions.", default=default_2018_answers) @@ -241,7 +244,7 @@ subroutine initialize_ALE_sponge_fixed(Iresttime, G, param_file, CS, data_h, nz_ ! Call the constructor for remapping control structure call initialize_remapping(CS%remap_cs, remapScheme, boundary_extrapolation=bndExtrapolation, & - answers_2018=answers_2018) + answers_2018=CS%remap_answers_2018) call log_param(param_file, mdl, "!Total sponge columns at h points", total_sponge_cols, & "The total number of columns where sponges are applied at h points.") @@ -397,7 +400,7 @@ subroutine initialize_ALE_sponge_varying(Iresttime, G, param_file, CS) real, allocatable, dimension(:,:) :: Iresttime_u !< inverse of the restoring time at u points [s-1] real, allocatable, dimension(:,:) :: Iresttime_v !< inverse of the restoring time at v points [s-1] logical :: bndExtrapolation = .true. ! If true, extrapolate boundaries - logical :: answers_2018, default_2018_answers + logical :: default_2018_answers logical :: spongeDataOngrid = .false. integer :: i, j, k, col, total_sponge_cols, total_sponge_cols_u, total_sponge_cols_v character(len=10) :: remapScheme @@ -431,7 +434,7 @@ subroutine initialize_ALE_sponge_varying(Iresttime, G, param_file, CS) call get_param(param_file, mdl, "DEFAULT_2018_ANSWERS", default_2018_answers, & "This sets the default value for the various _2018_ANSWERS parameters.", & default=.true.) - call get_param(param_file, mdl, "REMAPPING_2018_ANSWERS", answers_2018, & + call get_param(param_file, mdl, "REMAPPING_2018_ANSWERS", CS%remap_answers_2018, & "If true, use the order of arithmetic and expressions that recover the "//& "answers from the end of 2018. Otherwise, use updated and more robust "//& "forms of the same expressions.", default=default_2018_answers) @@ -470,7 +473,7 @@ subroutine initialize_ALE_sponge_varying(Iresttime, G, param_file, CS) ! Call the constructor for remapping control structure call initialize_remapping(CS%remap_cs, remapScheme, boundary_extrapolation=bndExtrapolation, & - answers_2018=answers_2018) + answers_2018=CS%remap_answers_2018) call log_param(param_file, mdl, "!Total sponge columns at h points", total_sponge_cols, & "The total number of columns where sponges are applied at h points.") if (CS%sponge_uv) then @@ -804,7 +807,9 @@ subroutine apply_ALE_sponge(h, dt, G, GV, US, CS, Time) is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke if (.not.associated(CS)) return - if (GV%Boussinesq) then + if (.not.CS%remap_answers_2018) then + h_neglect = GV%H_subroundoff ; h_neglect_edge = GV%H_subroundoff + elseif (GV%Boussinesq) then h_neglect = GV%m_to_H*1.0e-30 ; h_neglect_edge = GV%m_to_H*1.0e-10 else h_neglect = GV%kg_m2_to_H*1.0e-30 ; h_neglect_edge = GV%kg_m2_to_H*1.0e-10 diff --git a/src/parameterizations/vertical/MOM_tidal_mixing.F90 b/src/parameterizations/vertical/MOM_tidal_mixing.F90 index f60c54be6a..8c9ae6d62c 100644 --- a/src/parameterizations/vertical/MOM_tidal_mixing.F90 +++ b/src/parameterizations/vertical/MOM_tidal_mixing.F90 @@ -142,6 +142,9 @@ module MOM_tidal_mixing real :: tidal_diss_lim_tc !< CVMix-specific dissipation limit depth for !! tidal-energy-constituent data [Z ~> m]. type(remapping_CS) :: remap_CS !< The control structure for remapping + logical :: remap_answers_2018 = .true. !> If true, use the order of arithmetic and expressions that + !! recover the remapping answers from 2018. If false, use more + !! robust forms of the same remapping expressions. ! Data containers real, pointer, dimension(:,:) :: TKE_Niku => NULL() !< Lee wave driven Turbulent Kinetic Energy input @@ -270,6 +273,10 @@ logical function tidal_mixing_init(Time, G, GV, US, param_file, diag, CS) "If true, use the order of arithmetic and expressions that recover the "//& "answers from the end of 2018. Otherwise, use updated and more robust "//& "forms of the same expressions.", default=default_2018_answers) + call get_param(param_file, mdl, "REMAPPING_2018_ANSWERS", CS%remap_answers_2018, & + "If true, use the order of arithmetic and expressions that recover the "//& + "answers from the end of 2018. Otherwise, use updated and more robust "//& + "forms of the same expressions.", default=default_2018_answers) if (CS%int_tide_dissipation) then @@ -1652,7 +1659,8 @@ subroutine read_tidal_constituents(G, US, tidal_energy_file, CS) ! initialize input remapping: call initialize_remapping(CS%remap_cs, remapping_scheme="PLM", & - boundary_extrapolation=.false., check_remapping=CS%debug) + boundary_extrapolation=.false., check_remapping=CS%debug, & + answers_2018=CS%remap_answers_2018) deallocate(tc_m2) deallocate(tc_s2) diff --git a/src/tracer/MOM_neutral_diffusion.F90 b/src/tracer/MOM_neutral_diffusion.F90 index ed004acc1b..b3e75ccfad 100644 --- a/src/tracer/MOM_neutral_diffusion.F90 +++ b/src/tracer/MOM_neutral_diffusion.F90 @@ -86,8 +86,11 @@ module MOM_neutral_diffusion integer :: id_vhEff_2d = -1 !< Diagnostic IDs real :: C_p !< heat capacity of seawater (J kg-1 K-1) - type(EOS_type), pointer :: EOS !< Equation of state parameters - type(remapping_CS) :: remap_CS !< Remapping control structure used to create sublayers + type(EOS_type), pointer :: EOS !< Equation of state parameters + type(remapping_CS) :: remap_CS !< Remapping control structure used to create sublayers + logical :: remap_answers_2018 !< If true, use the order of arithmetic and expressions that + !! recover the answers for remapping from the end of 2018. + !! Otherwise, use more robust forms of the same expressions. end type neutral_diffusion_CS ! This include declares and sets the variable "version". @@ -108,7 +111,7 @@ logical function neutral_diffusion_init(Time, G, param_file, diag, EOS, CS) ! Local variables character(len=256) :: mesg ! Message for error messages. character(len=80) :: string ! Temporary strings - logical :: answers_2018, default_2018_answers + logical :: default_2018_answers logical :: boundary_extrap if (associated(CS)) then @@ -158,12 +161,12 @@ logical function neutral_diffusion_init(Time, G, param_file, diag, EOS, CS) call get_param(param_file, mdl, "DEFAULT_2018_ANSWERS", default_2018_answers, & "This sets the default value for the various _2018_ANSWERS parameters.", & default=.true.) - call get_param(param_file, mdl, "REMAPPING_2018_ANSWERS", answers_2018, & + call get_param(param_file, mdl, "REMAPPING_2018_ANSWERS", CS%remap_answers_2018, & "If true, use the order of arithmetic and expressions that recover the "//& "answers from the end of 2018. Otherwise, use updated and more robust "//& "forms of the same expressions.", default=default_2018_answers) call initialize_remapping( CS%remap_CS, string, boundary_extrapolation=boundary_extrap, & - answers_2018=answers_2018 ) + answers_2018=CS%remap_answers_2018 ) call extract_member_remapping_CS(CS%remap_CS, degree=CS%deg) call get_param(param_file, mdl, "NEUTRAL_POS_METHOD", CS%neutral_pos_method, & "Method used to find the neutral position \n"// & @@ -254,18 +257,18 @@ subroutine neutral_diffusion_calc_coeffs(G, GV, h, T, S, CS) ! Local variables integer :: i, j, k ! Variables used for reconstructions - real, dimension(SZK_(G),2) :: ppoly_r_S ! Reconstruction slopes - real, dimension(SZI_(G), SZJ_(G)) :: hEff_sum + real, dimension(SZK_(G),2) :: ppoly_r_S ! Reconstruction slopes + real, dimension(SZI_(G), SZJ_(G)) :: hEff_sum ! Summed effective face thicknesses [H ~> m or kg m-2] integer :: iMethod real, dimension(SZI_(G)) :: ref_pres ! Reference pressure used to calculate alpha/beta - real, dimension(SZI_(G)) :: rho_tmp ! Routiine to calculate drho_dp, returns density which is not used - real :: h_neglect, h_neglect_edge - real :: pa_to_H + real :: h_neglect, h_neglect_edge ! Negligible thicknesses [H ~> m or kg m-2] + real :: pa_to_H ! A conversion factor from Pa to H [H Pa-1 ~> m Pa-1 or s2 m-2] pa_to_H = 1. / GV%H_to_pa - !### Try replacing both of these with GV%H_subroundoff - if (GV%Boussinesq) then + if (.not.CS%remap_answers_2018) then + h_neglect = GV%H_subroundoff ; h_neglect_edge = GV%H_subroundoff + elseif (GV%Boussinesq) then h_neglect = GV%m_to_H*1.0e-30 ; h_neglect_edge = GV%m_to_H*1.0e-10 else h_neglect = GV%kg_m2_to_H*1.0e-30 ; h_neglect_edge = GV%kg_m2_to_H*1.0e-10 @@ -466,9 +469,11 @@ subroutine neutral_diffusion(G, GV, h, Coef_x, Coef_y, dt, Reg, US, CS) real :: Idt ! The inverse of the time step [T-1 ~> s-1] real :: h_neglect, h_neglect_edge - !### Try replacing both of these with GV%H_subroundoff - h_neglect_edge = GV%m_to_H*1.0e-10 - h_neglect = GV%m_to_H*1.0e-30 + if (.not.CS%remap_answers_2018) then + h_neglect = GV%H_subroundoff ; h_neglect_edge = GV%H_subroundoff + else + h_neglect = GV%m_to_H*1.0e-30 ; h_neglect_edge = GV%m_to_H*1.0e-10 + endif nk = GV%ke @@ -1710,8 +1715,8 @@ subroutine neutral_surface_flux(nk, nsurf, deg, hl, hr, Tl, Tr, PiL, PiR, KoL, K integer, intent(in) :: nk !< Number of levels integer, intent(in) :: nsurf !< Number of neutral surfaces integer, intent(in) :: deg !< Degree of polynomial reconstructions - real, dimension(nk), intent(in) :: hl !< Left-column layer thickness [Pa] - real, dimension(nk), intent(in) :: hr !< Right-column layer thickness [Pa] + real, dimension(nk), intent(in) :: hl !< Left-column layer thickness [H or Pa] + real, dimension(nk), intent(in) :: hr !< Right-column layer thickness [H or Pa] real, dimension(nk), intent(in) :: Tl !< Left-column layer tracer (conc, e.g. degC) real, dimension(nk), intent(in) :: Tr !< Right-column layer tracer (conc, e.g. degC) real, dimension(nsurf), intent(in) :: PiL !< Fractional position of neutral surface @@ -1728,9 +1733,8 @@ subroutine neutral_surface_flux(nk, nsurf, deg, hl, hr, Tl, Tr, PiL, PiR, KoL, K !! in the same units as h0. 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. + real, optional, intent(in) :: h_neglect_edge !< A negligibly small width used for + !! edge value calculations if continuous is false. ! Local variables integer :: k_sublayer, klb, klt, krb, krt, k real :: T_right_top, T_right_bottom, T_right_layer, T_right_sub, T_right_top_int, T_right_bot_int @@ -1934,9 +1938,9 @@ logical function ndiff_unit_tests_continuous(verbose) real, dimension(2*nk+1) :: Flx ! Test flux integer :: k logical :: v - real :: h_neglect, h_neglect_edge + real :: h_neglect - h_neglect_edge = 1.0e-10 ; h_neglect = 1.0e-30 + h_neglect = 1.0e-30 v = verbose @@ -2031,14 +2035,12 @@ logical function ndiff_unit_tests_continuous(verbose) (/0.,0.,10.,10.,20.,20.,30.,30./), '... right positions') call neutral_surface_flux(3, 2*3+2, 2, (/10.,10.,10./), (/10.,10.,10./), & ! nk, hL, hR (/20.,16.,12./), (/20.,16.,12./), & ! Tl, Tr - PiLRo, PiRLo, KoL, KoR, hEff, Flx, .true., & - h_neglect, h_neglect_edge=h_neglect_edge) + PiLRo, PiRLo, KoL, KoR, hEff, Flx, .true., h_neglect) ndiff_unit_tests_continuous = ndiff_unit_tests_continuous .or. test_data1d(v, 7, Flx, & (/0.,0.,0.,0.,0.,0.,0./), 'Identical columns, rho flux (=0)') call neutral_surface_flux(3, 2*3+2, 2, (/10.,10.,10./), (/10.,10.,10./), & ! nk, hL, hR (/-1.,-1.,-1./), (/1.,1.,1./), & ! Sl, Sr - PiLRo, PiRLo, KoL, KoR, hEff, Flx, .true., & - h_neglect, h_neglect_edge=h_neglect_edge) + PiLRo, PiRLo, KoL, KoR, hEff, Flx, .true., h_neglect) ndiff_unit_tests_continuous = ndiff_unit_tests_continuous .or. test_data1d(v, 7, Flx, & (/0.,20.,0.,20.,0.,20.,0./), 'Identical columns, S flux') @@ -2207,15 +2209,12 @@ logical function ndiff_unit_tests_discontinuous(verbose) logical, dimension(nk) :: stable_l, stable_r integer :: iMethod integer :: ns_l, ns_r - real :: h_neglect, h_neglect_edge integer :: k logical :: v v = verbose ndiff_unit_tests_discontinuous = .false. ! Normally return false write(*,*) '==== MOM_neutral_diffusion: ndiff_unit_tests_discontinuous =' -! - h_neglect = 1.0e-30 ; h_neglect_edge = 1.0e-10 ! Unit tests for find_neutral_surface_positions_discontinuous ! Salinity is 0 for all these tests @@ -2432,7 +2431,7 @@ logical function ndiff_unit_tests_discontinuous(verbose) find_neutral_pos_linear(CS, 0., 10., 35., 0., -0.2, 0., & 0., -0.4, 0., 10., -0.6, 0., & (/12.,-4./), (/34.,0./)), "Temp stratified Linearized Alpha/Beta")) -! ! EOS linear in S, insensitive to T + ! EOS linear in S, insensitive to T ndiff_unit_tests_discontinuous = ndiff_unit_tests_discontinuous .or. (test_rnp(0.5, & find_neutral_pos_linear(CS, 0., 10., 35., 0., 0., 0.8, & 0., 0., 1.0, 10., 0., 0.5, & From bc2191d52c653fb14b89b24470b108d0cfa206e8 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 19 Dec 2019 18:49:18 -0500 Subject: [PATCH 013/316] Add h_neglect to h_u for vertical viscosity Add a negligible thickness to the thicknesses at velocity points that are used in the vertical viscosity code to avoid the possibility of NaNs when the layer thicknesses are zero. All answers in the MOM6-examples test cases are bitwise identical. --- src/parameterizations/vertical/MOM_vert_friction.F90 | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/src/parameterizations/vertical/MOM_vert_friction.F90 b/src/parameterizations/vertical/MOM_vert_friction.F90 index a6a23d2adf..462b97788f 100644 --- a/src/parameterizations/vertical/MOM_vert_friction.F90 +++ b/src/parameterizations/vertical/MOM_vert_friction.F90 @@ -821,13 +821,13 @@ subroutine vertvisc_coef(u, v, h, forces, visc, dt, G, GV, US, CS, OBC) do k=1,nz ; do I=Isq,Ieq ; if (do_i_shelf(I)) then ! Should we instead take the inverse of the average of the inverses? CS%h_u(I,j,k) = forces%frac_shelf_u(I,j) * hvel_shelf(I,k) + & - (1.0-forces%frac_shelf_u(I,j)) * hvel(I,k) + (1.0-forces%frac_shelf_u(I,j)) * hvel(I,k) + h_neglect elseif (do_i(I)) then - CS%h_u(I,j,k) = hvel(I,k) + CS%h_u(I,j,k) = hvel(I,k) + h_neglect endif ; enddo ; enddo else do K=1,nz+1 ; do I=Isq,Ieq ; if (do_i(I)) CS%a_u(I,j,K) = a_cpl(I,K) ; enddo ; enddo - do k=1,nz ; do I=Isq,Ieq ; if (do_i(I)) CS%h_u(I,j,k) = hvel(I,k) ; enddo ; enddo + do k=1,nz ; do I=Isq,Ieq ; if (do_i(I)) CS%h_u(I,j,k) = hvel(I,k) + h_neglect ; enddo ; enddo endif ! Diagnose total Kv at u-points @@ -989,13 +989,13 @@ subroutine vertvisc_coef(u, v, h, forces, visc, dt, G, GV, US, CS, OBC) do k=1,nz ; do i=is,ie ; if (do_i_shelf(i)) then ! Should we instead take the inverse of the average of the inverses? CS%h_v(i,J,k) = forces%frac_shelf_v(i,J) * hvel_shelf(i,k) + & - (1.0-forces%frac_shelf_v(i,J)) * hvel(i,k) + (1.0-forces%frac_shelf_v(i,J)) * hvel(i,k) + h_neglect elseif (do_i(i)) then - CS%h_v(i,J,k) = hvel(i,k) + CS%h_v(i,J,k) = hvel(i,k) + h_neglect endif ; enddo ; enddo else do K=1,nz+1 ; do i=is,ie ; if (do_i(i)) CS%a_v(i,J,K) = a_cpl(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 + do k=1,nz ; do i=is,ie ; if (do_i(i)) CS%h_v(i,J,k) = hvel(i,k) + h_neglect ; enddo ; enddo endif ! Diagnose total Kv at v-points From e0554d4329d5541aa15cffdc25691cb24584cf7f Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 19 Dec 2019 18:49:50 -0500 Subject: [PATCH 014/316] (*)Safer edge value estimates for very thin layers Adopted safer handling of near-massless layers in the implicit edge value calculations for remapping when REMAPPING_2018_ANSWERS is false. This will change answers slightly in that case, but all of the MOM6-examples test cases are bitwise identical. --- src/ALE/regrid_edge_slopes.F90 | 52 +++++++++++++++------------------- src/ALE/regrid_edge_values.F90 | 43 +++++++++++++++------------- 2 files changed, 47 insertions(+), 48 deletions(-) diff --git a/src/ALE/regrid_edge_slopes.F90 b/src/ALE/regrid_edge_slopes.F90 index e0611d5267..9a34267e79 100644 --- a/src/ALE/regrid_edge_slopes.F90 +++ b/src/ALE/regrid_edge_slopes.F90 @@ -63,7 +63,7 @@ subroutine edge_slopes_implicit_h3( N, h, u, edge_slopes, h_neglect, answers_201 real :: h_min ! A minimal cell width [H] real :: d ! A temporary variable [H3] real :: I_d ! A temporary variable [nondim] - real :: I_h, I_hshear ! Inverses of thicknesses [H-1] + real :: I_h ! Inverses of thicknesses [H-1] real :: alpha, beta ! stencil coefficients [nondim] real :: a, b ! weights of cells [H-1] real, parameter :: C1_12 = 1.0 / 12.0 @@ -116,35 +116,29 @@ subroutine edge_slopes_implicit_h3( N, h, u, edge_slopes, h_neglect, answers_201 tri_b(i+1) = a * u(i) + b * u(i+1) else ! Get cell widths - h0 = h(i) - h1 = h(i+1) + h0 = max(h(i), hNeglect) + h1 = max(h(i+1), hNeglect) + + I_h = 1.0 / (h0 + h1) + h0 = h0 * I_h ; h1 = h1 * I_h + + h0h1 = h0 * h1 ; h0_2 = h0 * h0 ; h1_2 = h1 * h1 + h0_3 = h0_2 * h0 ; h1_3 = h1_2 * h1 + + I_d = 1.0 / (4.0 * h0h1 * ( h0 + h1 ) + h1_3 + h0_3) ! = 1 / ((h0 + h1)**3 + h0*h1*(h0 + h1)) + + ! Set the tridiagonal coefficients + tri_l(i+1) = (h1 * ((h0_2 + h0h1) - h1_2)) * I_d + ! tri_d(i+1) = 1.0 + tri_c(i+1) = 2.0 * ((h0_2 + h1_2) * (h0 + h1)) * I_d + tri_u(i+1) = (h0 * ((h1_2 + h0h1) - h0_2)) * I_d + ! The following expressions have been simplified using the nondimensionalization above: + ! I_d = 1.0 / (1.0 + h0h1) + ! tri_l(i+1) = (h0h1 - h1_3) * I_d + ! tri_c(i+1) = 2.0 * (h0_2 + h1_2) * I_d + ! tri_u(i+1) = (h0h1 - h0_3) * I_d - if (h0+h1 == 0.) then - ! Avoid singularities when h0+h1=0 by using values for equally spaced layers and no source term. - tri_l(i+1) = 0.1 - ! tri_d(i+1) = 1.0 - tri_c(i+1) = 0.8 - tri_u(i+1) = 0.1 - tri_b(i+1) = 0.0 - else - ! Auxiliary calculations - I_hshear = 1.0 / (h0 + h1 + hNeglect) - I_h = 1.0 / (h0 + h1) - h0 = h0 * I_h ; h1 = h1 * I_h - - h0h1 = h0 * h1 ; h0_2 = h0 * h0 ; h1_2 = h1 * h1 - h0_3 = h0_2 * h0 ; h1_3 = h1_2 * h1 - - I_d = 1.0 / (4.0 * h0h1 * ( h0 + h1 ) + h1_3 + h0_3) ! = 1 / ((h0 + h1)**3 + (h0 + h1)) - - ! Set the tridiagonal coefficients - tri_l(i+1) = (h1 * ((h0_2 + h0h1) - h1_2)) * I_d - ! tri_d(i+1) = 1.0 - tri_c(i+1) = 2.0 * ((h0_2 + h1_2) * (h0 + h1)) * I_d - tri_u(i+1) = (h0 * ((h1_2 + h0h1) - h0_2)) * I_d - - tri_b(i+1) = 12.0 * (h0h1 * I_d) * ((u(i+1) - u(i)) * I_hshear) - endif + tri_b(i+1) = 12.0 * (h0h1 * I_d) * ((u(i+1) - u(i)) * I_h) endif enddo ! end loop on cells diff --git a/src/ALE/regrid_edge_values.F90 b/src/ALE/regrid_edge_values.F90 index 7dbea4b62b..479fd5c99f 100644 --- a/src/ALE/regrid_edge_values.F90 +++ b/src/ALE/regrid_edge_values.F90 @@ -244,7 +244,11 @@ subroutine edge_values_explicit_h4( N, h, u, edge_val, h_neglect, answers_2018 ) logical :: use_2018_answers ! If true use older, less acccurate expressions. use_2018_answers = .true. ; if (present(answers_2018)) use_2018_answers = answers_2018 - hNeglect = hNeglect_edge_dflt ; if (present(h_neglect)) hNeglect = h_neglect + if (use_2018_answers) then + hNeglect = hNeglect_edge_dflt ; if (present(h_neglect)) hNeglect = h_neglect + else + hNeglect = hNeglect_dflt ; if (present(h_neglect)) hNeglect = h_neglect + endif ! Loop on interior cells do i = 3,N-1 @@ -440,16 +444,18 @@ subroutine edge_values_implicit_h4( N, h, u, edge_val, h_neglect, answers_2018 ) logical :: use_2018_answers ! If true use older, less acccurate expressions. use_2018_answers = .true. ; if (present(answers_2018)) use_2018_answers = answers_2018 - hNeglect = hNeglect_edge_dflt ; if (present(h_neglect)) hNeglect = h_neglect + if (use_2018_answers) then + hNeglect = hNeglect_edge_dflt ; if (present(h_neglect)) hNeglect = h_neglect + else + hNeglect = hNeglect_dflt ; if (present(h_neglect)) hNeglect = h_neglect + endif ! Loop on cells (except last one) do i = 1,N-1 - - ! Get cell widths - h0 = h(i) - h1 = h(i+1) - if (use_2018_answers) then + ! Get cell widths + h0 = h(i) + h1 = h(i+1) ! Avoid singularities when h0+h1=0 if (h0+h1==0.) then h0 = hNeglect @@ -471,18 +477,17 @@ subroutine edge_values_implicit_h4( N, h, u, edge_val, h_neglect, answers_2018 ) tri_d(i+1) = 1.0 else ! Use expressions with less sensitivity to roundoff - if (h0+h1==0.) then ! Avoid singularities when h0+h1=0 - alpha = 0.25 ; beta = 0.25 ; abmix = 0.25 - else - ! The 1e-12 here attempts to balance truncation errors from the differences of - ! large numbers against errors from approximating thin layers as non-vanishing. - if (abs(h0) < 1.0e-12*abs(h1)) h0 = 1.0e-12*h1 - if (abs(h1) < 1.0e-12*abs(h0)) h1 = 1.0e-12*h0 - I_h2 = 1.0 / ((h0 + h1)**2) - alpha = (h1 * h1) * I_h2 - beta = (h0 * h0) * I_h2 - abmix = (h0 * h1) * I_h2 - endif + ! Get cell widths + h0 = max(h(i), hNeglect) + h1 = max(h(i+1), hNeglect) + ! The 1e-12 here attempts to balance truncation errors from the differences of + ! large numbers against errors from approximating thin layers as non-vanishing. + if (abs(h0) < 1.0e-12*abs(h1)) h0 = 1.0e-12*h1 + if (abs(h1) < 1.0e-12*abs(h0)) h1 = 1.0e-12*h0 + I_h2 = 1.0 / ((h0 + h1)**2) + alpha = (h1 * h1) * I_h2 + beta = (h0 * h0) * I_h2 + abmix = (h0 * h1) * I_h2 a = 2.0 * alpha * ( alpha + 2.0 * beta + 3.0 * abmix ) b = 2.0 * beta * ( beta + 2.0 * alpha + 3.0 * abmix ) From 4265603469a34033182d29e6b25f4c0d2b46e143 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 19 Dec 2019 18:50:21 -0500 Subject: [PATCH 015/316] +Added REGULARIZE_LAYERS_2018_ANSWERS Added two new runtime parameters, REGULARIZE_LAYERS_2018_ANSWERS and REG_SFC_DENSE_MATCH_TOLERANCE to improve the behavior of the regularize_layers code with nearly massless layers. When this new parameter is enabled, it will change (improve) answers, but by default all answers are bitwise identical. --- .../vertical/MOM_regularize_layers.F90 | 75 +++++++++++-------- 1 file changed, 45 insertions(+), 30 deletions(-) diff --git a/src/parameterizations/vertical/MOM_regularize_layers.F90 b/src/parameterizations/vertical/MOM_regularize_layers.F90 index 57f7bd2444..26310af94c 100644 --- a/src/parameterizations/vertical/MOM_regularize_layers.F90 +++ b/src/parameterizations/vertical/MOM_regularize_layers.F90 @@ -31,22 +31,28 @@ module MOM_regularize_layers logical :: reg_sfc_detrain !< If true, allow the buffer layers to detrain into the !! interior as a part of the restructuring when !! regularize_surface_layers is true + real :: density_match_tol !< A relative tolerance for how well the densities must match + !! with the target densities during detrainment when regularizing + !! the near-surface layers [nondim] real :: h_def_tol1 !< The value of the relative thickness deficit at !! which to start modifying the structure, 0.5 by - !! default (or a thickness ratio of 5.83). + !! default (or a thickness ratio of 5.83) [nondim]. real :: h_def_tol2 !< The value of the relative thickness deficit at !! which to the structure modification is in full - !! force, now 20% of the way from h_def_tol1 to 1. + !! force, now 20% of the way from h_def_tol1 to 1 [nondim]. real :: h_def_tol3 !< The value of the relative thickness deficit at which to start !! detrainment from the buffer layers to the interior, now 30% of - !! the way from h_def_tol1 to 1. + !! the way from h_def_tol1 to 1 [nondim]. real :: h_def_tol4 !< The value of the relative thickness deficit at which to do !! detrainment from the buffer layers to the interior at full - !! force, now 50% of the way from h_def_tol1 to 1. + !! force, now 50% of the way from h_def_tol1 to 1 [nondim]. real :: Hmix_min !< The minimum mixed layer thickness [H ~> m or kg m-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. + logical :: answers_2018 !< If true, use the order of arithmetic and expressions that recover the + !! answers from the end of 2018. Otherwise, use updated and more robust + !! forms of the same expressions. logical :: debug !< If true, do more thorough checks for debugging purposes. integer :: id_def_rat = -1 !< A diagnostic ID @@ -209,7 +215,7 @@ subroutine regularize_surface(h, tv, dt, ea, eb, G, GV, US, CS) logical :: debug = .false. logical :: fatal_error character(len=256) :: mesg ! Message for error messages. - integer :: i, j, k, is, ie, js, je, nz, nkmb, nkml, k1, k2, k3, ks, nz_filt + integer :: i, j, k, is, ie, js, je, nz, nkmb, nkml, k1, k2, k3, ks, nz_filt, kmax_d_ea is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke @@ -300,20 +306,9 @@ subroutine regularize_surface(h, tv, dt, ea, eb, G, GV, US, CS) ! Now restructure the layers. -!$OMP parallel do default(none) shared(is,ie,js,je,nz,do_j,def_rat_h,CS,nkmb,G,GV,US, & -!$OMP e,I_dtol,h,tv,debug,h_neglect,p_ref_cv,ea, & -!$OMP eb,id_clock_EOS,nkml) & -!$OMP private(d_ea,d_eb,max_def_rat,do_i,nz_filt,e_e,e_w,& -!$OMP e_n,e_s,wt,e_filt,e_2d,h_2d,T_2d,S_2d, & -!$OMP h_2d_init,T_2d_init,S_2d_init,ent_any, & -!$OMP more_ent_i,ent_i,h_add_tgt,h_add_tot, & -!$OMP cols_left,h_add,h_prev,ks,det_any,det_i, & -!$OMP Rcv_tol,Rcv,k1,k2,h_det_tot,Rcv_min_det, & -!$OMP Rcv_max_det,h_deficit,h_tot3,Th_tot3, & -!$OMP Sh_tot3,scale,int_top,int_flux,int_Rflux, & -!$OMP int_Tflux,int_Sflux,int_bot,h_prev_1d, & -!$OMP h_tot1,Th_tot1,Sh_tot1,h_tot2,Th_tot2, & -!$OMP Sh_tot2,h_predicted,fatal_error,mesg ) + !$OMP parallel do default(private) shared(is,ie,js,je,nz,do_j,def_rat_h,CS,nkmb,G,GV,US, & + !$OMP e,I_dtol,h,tv,debug,h_neglect,p_ref_cv,ea, & + !$OMP eb,id_clock_EOS,nkml) & do j=js,je ; if (do_j(j)) then ! call cpu_clock_begin(id_clock_EOS) @@ -322,6 +317,7 @@ subroutine regularize_surface(h, tv, dt, ea, eb, G, GV, US, CS) ! call cpu_clock_end(id_clock_EOS) do k=1,nz ; do i=is,ie ; d_ea(i,k) = 0.0 ; d_eb(i,k) = 0.0 ; enddo ; enddo + kmax_d_ea = 0 max_def_rat = 0.0 do i=is,ie @@ -389,13 +385,18 @@ subroutine regularize_surface(h, tv, dt, ea, eb, G, GV, US, CS) if (e_2d(i,nkmb+1)-e_filt(i,nkmb+1) > h_2d(i,k) - GV%Angstrom_H) then h_add = h_2d(i,k) - GV%Angstrom_H h_2d(i,k) = GV%Angstrom_H + e_2d(i,nkmb+1) = e_2d(i,nkmb+1) - h_add else - h_add = e_2d(i,nkmb+1)-e_filt(i,nkmb+1) + h_add = e_2d(i,nkmb+1) - e_filt(i,nkmb+1) h_2d(i,k) = h_2d(i,k) - h_add + if (CS%answers_2018) then + e_2d(i,nkmb+1) = e_2d(i,nkmb+1) - h_add + else + e_2d(i,nkmb+1) = e_filt(i,nkmb+1) + endif endif d_eb(i,k-1) = d_eb(i,k-1) + h_add h_add_tot(i) = h_add_tot(i) + h_add - e_2d(i,nkmb+1) = e_2d(i,nkmb+1) - h_add h_prev = h_2d(i,nkmb) h_2d(i,nkmb) = h_2d(i,nkmb) + h_add @@ -436,7 +437,8 @@ subroutine regularize_surface(h, tv, dt, ea, eb, G, GV, US, CS) if (do_i(i) .and. (e_2d(i,nkmb+1) < e_filt(i,nkmb+1)) .and. & (def_rat_h(i,j) > CS%h_def_tol3)) then det_i(i) = .true. ; det_any = .true. - Rcv_tol(i) = min((def_rat_h(i,j) - CS%h_def_tol3), 1.0) + ! The CS%density_match_tol default value of 0.6 gives 20% overlap in acceptable densities. + Rcv_tol(i) = CS%density_match_tol * min((def_rat_h(i,j) - CS%h_def_tol3), 1.0) endif enddo endif @@ -454,12 +456,11 @@ subroutine regularize_surface(h, tv, dt, ea, eb, G, GV, US, CS) do ! This loop is terminated by exits. if (k1 <= 1) exit if (k2 <= nkmb) exit - ! ### The 0.6 here should be adjustable? It gives 20% overlap for now. - Rcv_min_det = (GV%Rlay(k2) + 0.6*Rcv_tol(i)*(GV%Rlay(k2-1)-GV%Rlay(k2))) + Rcv_min_det = (GV%Rlay(k2) + Rcv_tol(i)*(GV%Rlay(k2-1)-GV%Rlay(k2))) if (k2 < nz) then - Rcv_max_det = (GV%Rlay(k2) + 0.6*Rcv_tol(i)*(GV%Rlay(k2+1)-GV%Rlay(k2))) + Rcv_max_det = (GV%Rlay(k2) + Rcv_tol(i)*(GV%Rlay(k2+1)-GV%Rlay(k2))) else - Rcv_max_det = (GV%Rlay(nz) + 0.6*Rcv_tol(i)*(GV%Rlay(nz)-GV%Rlay(nz-1))) + Rcv_max_det = (GV%Rlay(nz) + Rcv_tol(i)*(GV%Rlay(nz)-GV%Rlay(nz-1))) endif if (Rcv(i,k1) > Rcv_max_det) & exit ! All shallower interior layers are too light for detrainment. @@ -476,7 +477,8 @@ subroutine regularize_surface(h, tv, dt, ea, eb, G, GV, US, CS) h_2d(i,k2) = h_2d(i,k2) + h_add e_2d(i,k2) = e_2d(i,k2+1) + h_2d(i,k2) d_ea(i,k2) = d_ea(i,k2) + h_add - ! ### THIS IS UPWIND. IT SHOULD BE HIGHER ORDER... + kmax_d_ea = max(kmax_d_ea, k2) + ! This is upwind. It should perhaps be higher order... T_2d(i,k2) = (h_prev*T_2d(i,k2) + h_add*T_2d(i,k1)) / h_2d(i,k2) S_2d(i,k2) = (h_prev*S_2d(i,k2) + h_add*S_2d(i,k1)) / h_2d(i,k2) h_det_tot = h_det_tot + h_add @@ -499,6 +501,7 @@ subroutine regularize_surface(h, tv, dt, ea, eb, G, GV, US, CS) h_2d(i,k2) = h_2d(i,k2) + h_add e_2d(i,k2) = e_2d(i,k2+1) + h_2d(i,k2) d_ea(i,k2) = d_ea(i,k2) + h_add + kmax_d_ea = max(kmax_d_ea, k2) T_2d(i,k2) = (h_prev*T_2d(i,k2) + h_add*T_2d(i,k1)) / h_2d(i,k2) S_2d(i,k2) = (h_prev*S_2d(i,k2) + h_add*S_2d(i,k1)) / h_2d(i,k2) h_det_tot = h_det_tot + h_add @@ -519,8 +522,7 @@ subroutine regularize_surface(h, tv, dt, ea, eb, G, GV, US, CS) enddo ! exit terminated loop. endif ; enddo - ! ### This could be faster if the deepest k with nonzero d_ea were kept. - do k=nz-1,nkmb+1,-1 ; do i=is,ie ; if (det_i(i)) then + do k=kmax_d_ea-1,nkmb+1,-1 ; do i=is,ie ; if (det_i(i)) then d_ea(i,k) = d_ea(i,k) + d_ea(i,k+1) endif ; enddo ; enddo endif ! Detrainment to the interior. @@ -550,7 +552,8 @@ subroutine regularize_surface(h, tv, dt, ea, eb, G, GV, US, CS) e_filt(i,2) = e_2d(i,nkml) endif - ! Map the water back into the layers. + ! Map the water back into the layers. There are not mixed or buffer layers that are exceedingly + ! small compared to the others, so the code here is less prone to roundoff than elsewhere in MOM6. k1 = 1 ; k2 = 1 int_top = 0.0 do k=1,nkmb+1 @@ -887,6 +890,7 @@ subroutine regularize_layers_init(Time, G, GV, param_file, diag, CS) #include "version_variable.h" character(len=40) :: mdl = "MOM_regularize_layers" ! This module's name. logical :: use_temperature + logical :: default_2018_answers integer :: isd, ied, jsd, jed isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed @@ -911,6 +915,17 @@ subroutine regularize_layers_init(Time, G, GV, param_file, diag, CS) "If true, allow the buffer layers to detrain into the "//& "interior as a part of the restructuring when "//& "REGULARIZE_SURFACE_LAYERS is true.", default=.true.) + call get_param(param_file, mdl, "REG_SFC_DENSE_MATCH_TOLERANCE", CS%density_match_tol, & + "A relative tolerance for how well the densities must match with the target "//& + "densities during detrainment when regularizing the near-surface layers. The "//& + "default of 0.6 gives 20% overlaps in density", units="nondim", default=0.6) + call get_param(param_file, mdl, "DEFAULT_2018_ANSWERS", default_2018_answers, & + "This sets the default value for the various _2018_ANSWERS parameters.", & + default=.true.) + call get_param(param_file, mdl, "REGULARIZE_LAYERS_2018_ANSWERS", CS%answers_2018, & + "If true, use the order of arithmetic and expressions that recover the "//& + "answers from the end of 2018. Otherwise, use updated and more robust "//& + "forms of the same expressions.", default=default_2018_answers) endif call get_param(param_file, mdl, "HMIX_MIN", CS%Hmix_min, & From 12260e234f1e88a7d0edeaea5ea79af1d98262bd Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sun, 22 Dec 2019 07:34:34 -0500 Subject: [PATCH 016/316] Corrected 2 dOxygen and 1 openMP directives Corrected syntax errors in 2 dOxygen comments and 1 openMP directive. All answers are bitwise identical. --- src/diagnostics/MOM_wave_speed.F90 | 2 +- src/parameterizations/vertical/MOM_regularize_layers.F90 | 2 +- src/parameterizations/vertical/MOM_tidal_mixing.F90 | 2 +- 3 files changed, 3 insertions(+), 3 deletions(-) diff --git a/src/diagnostics/MOM_wave_speed.F90 b/src/diagnostics/MOM_wave_speed.F90 index 376d0f36b2..56545dc50d 100644 --- a/src/diagnostics/MOM_wave_speed.F90 +++ b/src/diagnostics/MOM_wave_speed.F90 @@ -40,7 +40,7 @@ module MOM_wave_speed !! can be overridden by optional arguments. type(remapping_CS) :: remapping_CS !< Used for vertical remapping when calculating equivalent barotropic !! mode structure. - logical :: remap_answers_2018 = .true. !> If true, use the order of arithmetic and expressions that + logical :: remap_answers_2018 = .true. !< If true, use the order of arithmetic and expressions that !! recover the remapping answers from 2018. If false, use more !! robust forms of the same remapping expressions. type(diag_ctrl), pointer :: diag !< Diagnostics control structure diff --git a/src/parameterizations/vertical/MOM_regularize_layers.F90 b/src/parameterizations/vertical/MOM_regularize_layers.F90 index 26310af94c..d044f09b8a 100644 --- a/src/parameterizations/vertical/MOM_regularize_layers.F90 +++ b/src/parameterizations/vertical/MOM_regularize_layers.F90 @@ -308,7 +308,7 @@ subroutine regularize_surface(h, tv, dt, ea, eb, G, GV, US, CS) ! Now restructure the layers. !$OMP parallel do default(private) shared(is,ie,js,je,nz,do_j,def_rat_h,CS,nkmb,G,GV,US, & !$OMP e,I_dtol,h,tv,debug,h_neglect,p_ref_cv,ea, & - !$OMP eb,id_clock_EOS,nkml) & + !$OMP eb,id_clock_EOS,nkml) do j=js,je ; if (do_j(j)) then ! call cpu_clock_begin(id_clock_EOS) diff --git a/src/parameterizations/vertical/MOM_tidal_mixing.F90 b/src/parameterizations/vertical/MOM_tidal_mixing.F90 index 8c9ae6d62c..04b8e3347a 100644 --- a/src/parameterizations/vertical/MOM_tidal_mixing.F90 +++ b/src/parameterizations/vertical/MOM_tidal_mixing.F90 @@ -142,7 +142,7 @@ module MOM_tidal_mixing real :: tidal_diss_lim_tc !< CVMix-specific dissipation limit depth for !! tidal-energy-constituent data [Z ~> m]. type(remapping_CS) :: remap_CS !< The control structure for remapping - logical :: remap_answers_2018 = .true. !> If true, use the order of arithmetic and expressions that + logical :: remap_answers_2018 = .true. !< If true, use the order of arithmetic and expressions that !! recover the remapping answers from 2018. If false, use more !! robust forms of the same remapping expressions. From 2691e5927c03fff4e74bcfe3bc1d95719b63ac64 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 27 Dec 2019 16:06:16 -0500 Subject: [PATCH 017/316] (*)Set answers_2018 in calls to solve_linear_system Use the same value of ANSWERS_2018 in solve_linear_solver as in the rest of the edge_values or edge_slopes code. This will change answers slightly when REMAPPING_2018_ANSWERS is false, but the answers in the MOM6-examples test cases are bitwise identical. --- src/ALE/regrid_edge_slopes.F90 | 14 +++++++------- src/ALE/regrid_edge_values.F90 | 32 ++++++++++++++++---------------- 2 files changed, 23 insertions(+), 23 deletions(-) diff --git a/src/ALE/regrid_edge_slopes.F90 b/src/ALE/regrid_edge_slopes.F90 index 9a34267e79..7b5d8bfe54 100644 --- a/src/ALE/regrid_edge_slopes.F90 +++ b/src/ALE/regrid_edge_slopes.F90 @@ -172,7 +172,7 @@ subroutine edge_slopes_implicit_h3( N, h, u, edge_slopes, h_neglect, answers_201 Bsys(i) = u(i) * dx enddo - call solve_linear_system( Asys, Bsys, Csys, 4 ) + call solve_linear_system( Asys, Bsys, Csys, 4, .false. ) ! Set the first edge slope tri_b(1) = Csys(2) ! + x(1)*(2.0*Csys(3) + x(1)*(3.0*Csys(4))) @@ -213,7 +213,7 @@ subroutine edge_slopes_implicit_h3( N, h, u, edge_slopes, h_neglect, answers_201 Bsys(i) = u(N+1-i) * dx enddo - call solve_linear_system( Asys, Bsys, Csys, 4 ) + call solve_linear_system( Asys, Bsys, Csys, 4, .false. ) ! Set the last edge slope tri_b(N+1) = Csys(2) @@ -410,7 +410,7 @@ subroutine edge_slopes_implicit_h5( N, h, u, edge_slopes, h_neglect, answers_201 Bsys(:) = (/ 0.0, -1.0, 0.0, 0.0, 0.0, 0.0 /) - call solve_linear_system( Asys, Bsys, Csys, 6 ) + call solve_linear_system( Asys, Bsys, Csys, 6, use_2018_answers ) alpha = Csys(1) beta = Csys(2) @@ -523,7 +523,7 @@ subroutine edge_slopes_implicit_h5( N, h, u, edge_slopes, h_neglect, answers_201 Bsys(:) = (/ 0.0, -1.0, -h1, h1_2/2.0, -h1_3/6.0, h1_4/24.0 /) - call solve_linear_system( Asys, Bsys, Csys, 6 ) + call solve_linear_system( Asys, Bsys, Csys, 6, use_2018_answers ) alpha = Csys(1) beta = Csys(2) @@ -562,7 +562,7 @@ subroutine edge_slopes_implicit_h5( N, h, u, edge_slopes, h_neglect, answers_201 enddo - call solve_linear_system( Asys, Bsys, Csys, 6 ) + call solve_linear_system( Asys, Bsys, Csys, 6, use_2018_answers ) Dsys(1) = Csys(2) Dsys(2) = 2.0 * Csys(3) @@ -672,7 +672,7 @@ subroutine edge_slopes_implicit_h5( N, h, u, edge_slopes, h_neglect, answers_201 Bsys(:) = (/ 0.0, -1.0, h2, h2_2/2.0, h2_3/6.0, h2_4/24.0 /) - call solve_linear_system( Asys, Bsys, Csys, 6 ) + call solve_linear_system( Asys, Bsys, Csys, 6, use_2018_answers ) alpha = Csys(1) beta = Csys(2) @@ -708,7 +708,7 @@ subroutine edge_slopes_implicit_h5( N, h, u, edge_slopes, h_neglect, answers_201 Bsys(i) = u(N-6+i) * dx enddo - call solve_linear_system( Asys, Bsys, Csys, 6 ) + call solve_linear_system( Asys, Bsys, Csys, 6, use_2018_answers ) Dsys(1) = Csys(2) Dsys(2) = 2.0 * Csys(3) diff --git a/src/ALE/regrid_edge_values.F90 b/src/ALE/regrid_edge_values.F90 index 479fd5c99f..f43168ee4b 100644 --- a/src/ALE/regrid_edge_values.F90 +++ b/src/ALE/regrid_edge_values.F90 @@ -328,7 +328,7 @@ subroutine edge_values_explicit_h4( N, h, u, edge_val, h_neglect, answers_2018 ) B(i) = u(i) * dx enddo - call solve_linear_system( A, B, C, 4 ) + call solve_linear_system( A, B, C, 4, .false. ) ! Set the edge values of the first cell edge_val(1,1) = C(1) ! x(1) = 0 so ignore + x(1)*(C(2) + x(1)*(C(3) + x(1)*C(4))) @@ -374,7 +374,7 @@ subroutine edge_values_explicit_h4( N, h, u, edge_val, h_neglect, answers_2018 ) B(i) = u(N+1-i) * dx enddo - call solve_linear_system( A, B, C, 4 ) + call solve_linear_system( A, B, C, 4, .false. ) ! Set the last and second to last edge values edge_val(N,2) = C(1) @@ -425,7 +425,7 @@ subroutine edge_values_implicit_h4( N, h, u, edge_val, h_neglect, answers_2018 ) real :: h_min ! A minimal cell width [H] real :: h_sum ! A sum of adjacent thicknesses [H] real :: h0_2, h1_2, h0h1 - real :: d2, d4 + real :: h0ph1_2, h0ph1_4 real :: alpha, beta ! stencil coefficients [nondim] real :: I_h2, abmix ! stencil coefficients [nondim] real :: a, b @@ -463,17 +463,17 @@ subroutine edge_values_implicit_h4( N, h, u, edge_val, h_neglect, answers_2018 ) endif ! Auxiliary calculations - d2 = (h0 + h1) ** 2 - d4 = d2 ** 2 + h0ph1_2 = (h0 + h1)**2 + h0ph1_4 = h0ph1_2**2 h0h1 = h0 * h1 h0_2 = h0 * h0 h1_2 = h1 * h1 ! Coefficients - alpha = h1_2 / d2 - beta = h0_2 / d2 - a = 2.0 * h1_2 * ( h1_2 + 2.0 * h0_2 + 3.0 * h0h1 ) / d4 - b = 2.0 * h0_2 * ( h0_2 + 2.0 * h1_2 + 3.0 * h0h1 ) / d4 + alpha = h1_2 / h0ph1_2 + beta = h0_2 / h0ph1_2 + a = 2.0 * h1_2 * ( h1_2 + 2.0 * h0_2 + 3.0 * h0h1 ) / h0ph1_4 + b = 2.0 * h0_2 * ( h0_2 + 2.0 * h1_2 + 3.0 * h0h1 ) / h0ph1_4 tri_d(i+1) = 1.0 else ! Use expressions with less sensitivity to roundoff @@ -530,7 +530,7 @@ subroutine edge_values_implicit_h4( N, h, u, edge_val, h_neglect, answers_2018 ) Bsys(i) = u(i) * dx enddo - call solve_linear_system( Asys, Bsys, Csys, 4 ) + call solve_linear_system( Asys, Bsys, Csys, 4, .false. ) tri_b(1) = Csys(1) ! Set the first edge value, using the fact that x(1) = 0. tri_c(1) = 1.0 @@ -572,7 +572,7 @@ subroutine edge_values_implicit_h4( N, h, u, edge_val, h_neglect, answers_2018 ) Bsys(i) = u(N+1-i) * dx enddo - call solve_linear_system( Asys, Bsys, Csys, 4 ) + call solve_linear_system( Asys, Bsys, Csys, 4, .false. ) ! Set the last edge value tri_b(N+1) = Csys(1) @@ -778,7 +778,7 @@ subroutine edge_values_implicit_h6( N, h, u, edge_val, h_neglect, answers_2018 ) Bsys(:) = (/ -1.0, 0.0, 0.0, 0.0, 0.0, 0.0 /) - call solve_linear_system( Asys, Bsys, Csys, 6 ) + call solve_linear_system( Asys, Bsys, Csys, 6, use_2018_answers ) alpha = Csys(1) beta = Csys(2) @@ -901,7 +901,7 @@ subroutine edge_values_implicit_h6( N, h, u, edge_val, h_neglect, answers_2018 ) Bsys(:) = (/ -1.0, h1, -0.5*h1_2, h1_3/6.0, -h1_4/24.0, h1_5/120.0 /) - call solve_linear_system( Asys, Bsys, Csys, 6 ) + call solve_linear_system( Asys, Bsys, Csys, 6, use_2018_answers ) alpha = Csys(1) beta = Csys(2) @@ -940,7 +940,7 @@ subroutine edge_values_implicit_h6( N, h, u, edge_val, h_neglect, answers_2018 ) enddo - call solve_linear_system( Asys, Bsys, Csys, 6 ) + call solve_linear_system( Asys, Bsys, Csys, 6, use_2018_answers ) tri_l(1) = 0.0 tri_d(1) = 1.0 @@ -1054,7 +1054,7 @@ subroutine edge_values_implicit_h6( N, h, u, edge_val, h_neglect, answers_2018 ) Bsys(:) = (/ -1.0, -h2, -0.5*h2_2, -h2_3/6.0, -h2_4/24.0, -h2_5/120.0 /) - call solve_linear_system( Asys, Bsys, Csys, 6 ) + call solve_linear_system( Asys, Bsys, Csys, 6, use_2018_answers ) alpha = Csys(1) beta = Csys(2) @@ -1093,7 +1093,7 @@ subroutine edge_values_implicit_h6( N, h, u, edge_val, h_neglect, answers_2018 ) enddo - call solve_linear_system( Asys, Bsys, Csys, 6 ) + call solve_linear_system( Asys, Bsys, Csys, 6, use_2018_answers ) tri_l(N+1) = 0.0 tri_d(N+1) = 1.0 From 2a59632d401287094c29a9495ebd4c4b7e6a7997 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 2 Jan 2020 07:25:53 -0500 Subject: [PATCH 018/316] +Added subroutine linear_solver to regrid_solvers Added the new subroutine linear_solver to regrid_solvers. This new subroutine differs from solve_linear_system in that it only uses the newer expressions and it reverses the order of indicies in the matrix being solved to use stride-1 in memory. This new routine is being used with the newer algorithms in several edge_values and edge_slopes routines. All answers are bitwise identical. --- src/ALE/regrid_edge_slopes.F90 | 23 +++++------ src/ALE/regrid_edge_values.F90 | 43 +++++++++++---------- src/ALE/regrid_solvers.F90 | 70 ++++++++++++++++++++++++++++++++-- 3 files changed, 100 insertions(+), 36 deletions(-) diff --git a/src/ALE/regrid_edge_slopes.F90 b/src/ALE/regrid_edge_slopes.F90 index 7b5d8bfe54..02fa00f7fc 100644 --- a/src/ALE/regrid_edge_slopes.F90 +++ b/src/ALE/regrid_edge_slopes.F90 @@ -4,7 +4,8 @@ module regrid_edge_slopes ! This file is part of MOM6. See LICENSE.md for the license. -use regrid_solvers, only : solve_linear_system, solve_tridiagonal_system, solve_diag_dominant_tridiag +use regrid_solvers, only : solve_linear_system, solve_tridiagonal_system +use regrid_solvers, only : solve_diag_dominant_tridiag, linear_solver use polynomial_functions, only : evaluation_polynomial implicit none ; private @@ -165,14 +166,14 @@ subroutine edge_slopes_implicit_h3( N, h, u, edge_slopes, h_neglect, answers_201 dx = max(h_min, h(i) ) x(i+1) = x(i) + dx xavg = x(i) + 0.5*dx - Asys(i,1) = dx - Asys(i,2) = dx * xavg - Asys(i,3) = dx * (xavg**2 + C1_12*dx**2) - Asys(i,4) = dx * xavg * (xavg**2 + 0.25*dx**2) + Asys(1,i) = dx + Asys(2,i) = dx * xavg + Asys(3,i) = dx * (xavg**2 + C1_12*dx**2) + Asys(4,i) = dx * xavg * (xavg**2 + 0.25*dx**2) Bsys(i) = u(i) * dx enddo - call solve_linear_system( Asys, Bsys, Csys, 4, .false. ) + call linear_solver( 4, Asys, Bsys, Csys ) ! Set the first edge slope tri_b(1) = Csys(2) ! + x(1)*(2.0*Csys(3) + x(1)*(3.0*Csys(4))) @@ -205,15 +206,15 @@ subroutine edge_slopes_implicit_h3( N, h, u, edge_slopes, h_neglect, answers_201 dx = max(h_min, h(N+1-i) ) x(i+1) = x(i) + dx xavg = x(i) + 0.5*dx - Asys(i,1) = dx - Asys(i,2) = dx * xavg - Asys(i,3) = dx * (xavg**2 + C1_12*dx**2) - Asys(i,4) = dx * xavg * (xavg**2 + 0.25*dx**2) + Asys(1,i) = dx + Asys(2,i) = dx * xavg + Asys(3,i) = dx * (xavg**2 + C1_12*dx**2) + Asys(4,i) = dx * xavg * (xavg**2 + 0.25*dx**2) Bsys(i) = u(N+1-i) * dx enddo - call solve_linear_system( Asys, Bsys, Csys, 4, .false. ) + call linear_solver( 4, Asys, Bsys, Csys ) ! Set the last edge slope tri_b(N+1) = Csys(2) diff --git a/src/ALE/regrid_edge_values.F90 b/src/ALE/regrid_edge_values.F90 index f43168ee4b..78706ce4c4 100644 --- a/src/ALE/regrid_edge_values.F90 +++ b/src/ALE/regrid_edge_values.F90 @@ -3,7 +3,8 @@ module regrid_edge_values ! This file is part of MOM6. See LICENSE.md for the license. -use regrid_solvers, only : solve_linear_system, solve_tridiagonal_system, solve_diag_dominant_tridiag +use regrid_solvers, only : solve_linear_system, solve_tridiagonal_system +use regrid_solvers, only : solve_diag_dominant_tridiag, linear_solver use polynomial_functions, only : evaluation_polynomial implicit none ; private @@ -321,14 +322,14 @@ subroutine edge_values_explicit_h4( N, h, u, edge_val, h_neglect, answers_2018 ) dx = max(h_min, h(i) ) x(i+1) = x(i) + dx xavg = 0.5 * (x(i+1) + x(i)) - A(i,1) = dx - A(i,2) = dx * xavg - A(i,3) = dx * (xavg**2 + C1_12*dx**2) - A(i,4) = dx * xavg * (xavg**2 + 0.25*dx**2) + A(1,i) = dx + A(2,i) = dx * xavg + A(3,i) = dx * (xavg**2 + C1_12*dx**2) + A(4,i) = dx * xavg * (xavg**2 + 0.25*dx**2) B(i) = u(i) * dx enddo - call solve_linear_system( A, B, C, 4, .false. ) + call linear_solver( 4, A, B, C ) ! Set the edge values of the first cell edge_val(1,1) = C(1) ! x(1) = 0 so ignore + x(1)*(C(2) + x(1)*(C(3) + x(1)*C(4))) @@ -366,15 +367,15 @@ subroutine edge_values_explicit_h4( N, h, u, edge_val, h_neglect, answers_2018 ) x(i+1) = x(i) + dx xavg = x(i) + 0.5*dx - A(i,1) = dx - A(i,2) = dx * xavg - A(i,3) = dx * (xavg**2 + C1_12*dx**2) - A(i,4) = dx * xavg * (xavg**2 + 0.25*dx**2) + A(1,i) = dx + A(2,i) = dx * xavg + A(3,i) = dx * (xavg**2 + C1_12*dx**2) + A(4,i) = dx * xavg * (xavg**2 + 0.25*dx**2) B(i) = u(N+1-i) * dx enddo - call solve_linear_system( A, B, C, 4, .false. ) + call linear_solver( 4, A, B, C ) ! Set the last and second to last edge values edge_val(N,2) = C(1) @@ -523,14 +524,14 @@ subroutine edge_values_implicit_h4( N, h, u, edge_val, h_neglect, answers_2018 ) dx = max(h_min, h(i) ) x(i+1) = x(i) + dx xavg = x(i) + 0.5*dx - Asys(i,1) = dx - Asys(i,2) = dx * xavg - Asys(i,3) = dx * (xavg**2 + C1_12*dx**2) - Asys(i,4) = dx * xavg * (xavg**2 + 0.25*dx**2) + Asys(1,i) = dx + Asys(2,i) = dx * xavg + Asys(3,i) = dx * (xavg**2 + C1_12*dx**2) + Asys(4,i) = dx * xavg * (xavg**2 + 0.25*dx**2) Bsys(i) = u(i) * dx enddo - call solve_linear_system( Asys, Bsys, Csys, 4, .false. ) + call linear_solver( 4, Asys, Bsys, Csys ) tri_b(1) = Csys(1) ! Set the first edge value, using the fact that x(1) = 0. tri_c(1) = 1.0 @@ -564,15 +565,15 @@ subroutine edge_values_implicit_h4( N, h, u, edge_val, h_neglect, answers_2018 ) x(i+1) = x(i) + dx xavg = x(i) + 0.5*dx - Asys(i,1) = dx - Asys(i,2) = dx * xavg - Asys(i,3) = dx * (xavg**2 + C1_12*dx**2) - Asys(i,4) = dx * xavg * (xavg**2 + 0.25*dx**2) + Asys(1,i) = dx + Asys(2,i) = dx * xavg + Asys(3,i) = dx * (xavg**2 + C1_12*dx**2) + Asys(4,i) = dx * xavg * (xavg**2 + 0.25*dx**2) Bsys(i) = u(N+1-i) * dx enddo - call solve_linear_system( Asys, Bsys, Csys, 4, .false. ) + call linear_solver( 4, Asys, Bsys, Csys ) ! Set the last edge value tri_b(N+1) = Csys(1) diff --git a/src/ALE/regrid_solvers.F90 b/src/ALE/regrid_solvers.F90 index 3f8923b585..82b23832f4 100644 --- a/src/ALE/regrid_solvers.F90 +++ b/src/ALE/regrid_solvers.F90 @@ -7,7 +7,7 @@ module regrid_solvers implicit none ; private -public :: solve_linear_system, solve_tridiagonal_system, solve_diag_dominant_tridiag +public :: solve_linear_system, linear_solver, solve_tridiagonal_system, solve_diag_dominant_tridiag contains @@ -15,16 +15,16 @@ module regrid_solvers !! !! 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 R and X. +!! The matrix A must be square, with the first index varing down the column. subroutine solve_linear_system( A, R, X, N, answers_2018 ) integer, intent(in) :: N !< The size of the system real, dimension(N,N), intent(inout) :: A !< The matrix being inverted [nondim] real, dimension(N), intent(inout) :: R !< system right-hand side [A] real, dimension(N), intent(inout) :: X !< solution vector [A] - logical, optional, intent(in) :: answers_2018 !< If true use older, less acccurate expressions. + logical, optional, intent(in) :: answers_2018 !< If true or absent use older, less efficient expressions. ! Local variables real, parameter :: eps = 0.0 ! Minimum pivot magnitude allowed - real :: factor ! The factor that eliminates the leading nonzero element in a row. + real :: factor ! The factor that eliminates the leading nonzero element in a row. real :: pivot, I_pivot ! The pivot value and its reciprocal [nondim] real :: swap_a, swap_b logical :: found_pivot ! If true, a pivot has been found @@ -103,6 +103,68 @@ subroutine solve_linear_system( A, R, X, N, answers_2018 ) end subroutine solve_linear_system +!> Solve the linear system AX = R by Gaussian elimination +!! +!! This routine uses Gauss's algorithm to transform the system's original +!! matrix into an upper triangular matrix. Back substitution then yields the answer. +!! The matrix A must be square, with the first index varing along the row. +subroutine linear_solver( N, A, R, X ) + integer, intent(in) :: N !< The size of the system + real, dimension(N,N), intent(inout) :: A !< The matrix being inverted [nondim] + real, dimension(N), intent(inout) :: R !< system right-hand side [A] + real, dimension(N), intent(inout) :: X !< solution vector [A] + + ! Local variables + real, parameter :: eps = 0.0 ! Minimum pivot magnitude allowed + real :: factor ! The factor that eliminates the leading nonzero element in a row. + real :: I_pivot ! The reciprocal of the pivot value [inverse of the input units of a row of A] + real :: swap + logical :: found_pivot ! If true, a pivot has been found + integer :: i, j, k + + ! Loop on rows to transform the problem into multiplication by an upper-right matrix. + do i=1,N-1 + ! Seek a pivot for column i starting in row i, and continuing into the remaining rows. If the + ! pivot is in a row other than i, swap them. If no valid pivot is found, i = N+1 after this loop. + do k=i,N ; if ( abs( A(i,k) ) > eps ) exit ; enddo ! end loop to find pivot + if ( k > N ) then ! No pivot could be found and the system is singular. + write(0,*) ' A=',A + call MOM_error( FATAL, 'The linear system is singular !' ) + endif + + ! If the pivot is in a row that is different than row i, swap those two rows, noting that both + ! rows start with i-1 zero values. + if ( k /= i ) then + do j=i,N ; swap = A(j,i) ; A(j,i) = A(j,k) ; A(j,k) = swap ; enddo + swap = R(i) ; R(i) = R(k) ; R(k) = swap + endif + + ! Transform the pivot to 1 by dividing the entire row (right-hand side included) by the pivot + I_pivot = 1.0 / A(i,i) + A(i,i) = 1.0 + do j=i+1,N ; A(j,i) = A(j,i) * I_pivot ; enddo + R(i) = R(i) * I_pivot + + ! Put zeros in column for all rows below that contain the pivot (which is row i) + do k=i+1,N ! k is the row index + factor = A(i,k) + ! A(i,k) = 0.0 ! These elements are not used again, so this line can be skipped for speed. + do j=i+1,N ; A(j,k) = A(j,k) - factor * A(j,i) ; enddo + R(k) = R(k) - factor * R(i) + enddo + + enddo ! end loop on i + + ! Solve the system by back substituting into what is now an upper-right matrix. + X(N) = R(N) / A(N,N) ! The last row is now trivially solved. + do i=N-1,1,-1 ! loop on rows, starting from second to last row + X(i) = R(i) + do j=i+1,N ; X(i) = X(i) - A(j,i) * X(j) ; enddo + enddo + +end subroutine linear_solver + + !> Solve the tridiagonal system AX = R !! !! This routine uses Thomas's algorithm to solve the tridiagonal system AX = R. From 8d680404f60774321149037cdb7107df77944942 Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Thu, 2 Jan 2020 18:09:25 -0500 Subject: [PATCH 019/316] * Fixed sign error in thickness diffuse work This patch fixes a bug in the sign of the tendency of the work by thickness diffusion in the top layer along the u-points. This resolves a variance in model runs after a 90-degree rotation, and results are now consistent with the work_v calculation. This patch will change answers for any runs using work-based thickness diffusion. --- src/parameterizations/lateral/MOM_thickness_diffuse.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/parameterizations/lateral/MOM_thickness_diffuse.F90 b/src/parameterizations/lateral/MOM_thickness_diffuse.F90 index a567edb4be..29b91e08aa 100644 --- a/src/parameterizations/lateral/MOM_thickness_diffuse.F90 +++ b/src/parameterizations/lateral/MOM_thickness_diffuse.F90 @@ -1235,7 +1235,7 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV drdiB = drho_dT_u(I) * (T(i+1,j,1)-T(i,j,1)) + & drho_dS_u(I) * (S(i+1,j,1)-S(i,j,1)) endif - Work_u(I,j) = Work_u(I,j) + G_scale * & + Work_u(I,j) = Work_u(I,j) - G_scale * & ( (uhD(I,j,1) * drdiB) * 0.25 * & ((e(i,j,1) + e(i,j,2)) + (e(i+1,j,1) + e(i+1,j,2))) ) From e92490adf279f6426d5ace959d28b25a1e21ab2c Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sun, 5 Jan 2020 23:08:13 -0500 Subject: [PATCH 020/316] (*)Simplified edge-value linear systems Simplified matricies in one-sided edge-value calculations in the edge_slopes_implicit and edge_values_implicit schemes, dividing out common factors of dx when REMAPPING_2018_ANSWERS is false. Although all of these calculations are mathematically identical, the differences amount to multiplying then dividing by a common factor, which does change answers at roundoff when REMAPPING_2018_ANSWERS is false. Also simplified expressions and used clearer variable names in edge_values_implicit_h6 in ways that are bitwise identical, although using this option fails (as before) in many cases. All answers in the MOM6-examples test cases are bitwise identical by default. --- src/ALE/regrid_edge_slopes.F90 | 62 +++---- src/ALE/regrid_edge_values.F90 | 315 ++++++++++++++++----------------- 2 files changed, 178 insertions(+), 199 deletions(-) diff --git a/src/ALE/regrid_edge_slopes.F90 b/src/ALE/regrid_edge_slopes.F90 index 02fa00f7fc..3e31feb030 100644 --- a/src/ALE/regrid_edge_slopes.F90 +++ b/src/ALE/regrid_edge_slopes.F90 @@ -166,11 +166,11 @@ subroutine edge_slopes_implicit_h3( N, h, u, edge_slopes, h_neglect, answers_201 dx = max(h_min, h(i) ) x(i+1) = x(i) + dx xavg = x(i) + 0.5*dx - Asys(1,i) = dx - Asys(2,i) = dx * xavg - Asys(3,i) = dx * (xavg**2 + C1_12*dx**2) - Asys(4,i) = dx * xavg * (xavg**2 + 0.25*dx**2) - Bsys(i) = u(i) * dx + Asys(1,i) = 1.0 + Asys(2,i) = xavg + Asys(3,i) = (xavg**2 + C1_12*dx**2) + Asys(4,i) = xavg * (xavg**2 + 0.25*dx**2) + Bsys(i) = u(i) enddo call linear_solver( 4, Asys, Bsys, Csys ) @@ -206,12 +206,11 @@ subroutine edge_slopes_implicit_h3( N, h, u, edge_slopes, h_neglect, answers_201 dx = max(h_min, h(N+1-i) ) x(i+1) = x(i) + dx xavg = x(i) + 0.5*dx - Asys(1,i) = dx - Asys(2,i) = dx * xavg - Asys(3,i) = dx * (xavg**2 + C1_12*dx**2) - Asys(4,i) = dx * xavg * (xavg**2 + 0.25*dx**2) - - Bsys(i) = u(N+1-i) * dx + Asys(1,i) = 1.0 + Asys(2,i) = xavg + Asys(3,i) = (xavg**2 + C1_12*dx**2) + Asys(4,i) = xavg * (xavg**2 + 0.25*dx**2) + Bsys(i) = u(N+1-i) enddo call linear_solver( 4, Asys, Bsys, Csys ) @@ -540,26 +539,23 @@ subroutine edge_slopes_implicit_h5( N, h, u, edge_slopes, h_neglect, answers_201 ! Boundary conditions: left boundary x(1) = 0.0 - do i = 2,7 - x(i) = x(i-1) + h(i-1) - enddo - do i = 1,6 - dx = h(i) + x(i+1) = x(i) + dx if (use_2018_answers) then do j = 1,6 ; Asys(i,j) = ( (x(i+1)**j) - (x(i)**j) ) / j ; enddo + Bsys(i) = u(i) * dx else ! Use expressions with less sensitivity to roundoff xavg = 0.5 * (x(i+1) + x(i)) - Asys(i,1) = dx - Asys(i,2) = dx * xavg - Asys(i,3) = dx * (xavg**2 + C1_12*dx**2) - Asys(i,4) = dx * xavg * (xavg**2 + 0.25*dx**2) - Asys(i,5) = dx * (xavg**4 + 0.5*xavg**2*dx**2 + 0.0125*dx**4) - Asys(i,6) = dx * xavg * (xavg**4 + C5_6*xavg**2*dx**2 + 0.0625*dx**4) + Asys(i,1) = 1.0 + Asys(i,2) = xavg + Asys(i,3) = (xavg**2 + C1_12*dx**2) + Asys(i,4) = xavg * (xavg**2 + 0.25*dx**2) + Asys(i,5) = (xavg**4 + 0.5*xavg**2*dx**2 + 0.0125*dx**4) + Asys(i,6) = xavg * (xavg**4 + C5_6*xavg**2*dx**2 + 0.0625*dx**4) + Bsys(i) = u(i) endif - Bsys(i) = u(i) * dx enddo @@ -689,24 +685,22 @@ subroutine edge_slopes_implicit_h5( N, h, u, edge_slopes, h_neglect, answers_201 ! Boundary conditions: right boundary x(1) = 0.0 - do i = 2,7 - x(i) = x(i-1) + h(N-7+i) - enddo - do i = 1,6 dx = h(N-6+i) + x(i+1) = x(i) + dx if (use_2018_answers) then do j = 1,6 ; Asys(i,j) = ( (x(i+1)**j) - (x(i)**j) ) / j ; enddo + Bsys(i) = u(N-6+i) * dx else ! Use expressions with less sensitivity to roundoff xavg = 0.5 * (x(i+1) + x(i)) - Asys(i,1) = dx - Asys(i,2) = dx * xavg - Asys(i,3) = dx * (xavg**2 + C1_12*dx**2) - Asys(i,4) = dx * xavg * (xavg**2 + 0.25*dx**2) - Asys(i,5) = dx * (xavg**4 + 0.5*xavg**2*dx**2 + 0.0125*dx**4) - Asys(i,6) = dx * xavg * (xavg**4 + C5_6*xavg**2*dx**2 + 0.0625*dx**4) + Asys(i,1) = 1.0 + Asys(i,2) = xavg + Asys(i,3) = (xavg**2 + C1_12*dx**2) + Asys(i,4) = xavg * (xavg**2 + 0.25*dx**2) + Asys(i,5) = (xavg**4 + 0.5*xavg**2*dx**2 + 0.0125*dx**4) + Asys(i,6) = xavg * (xavg**4 + C5_6*xavg**2*dx**2 + 0.0625*dx**4) + Bsys(i) = u(N-6+i) endif - Bsys(i) = u(N-6+i) * dx enddo call solve_linear_system( Asys, Bsys, Csys, 6, use_2018_answers ) diff --git a/src/ALE/regrid_edge_values.F90 b/src/ALE/regrid_edge_values.F90 index 78706ce4c4..fd99b5aff6 100644 --- a/src/ALE/regrid_edge_values.F90 +++ b/src/ALE/regrid_edge_values.F90 @@ -322,11 +322,11 @@ subroutine edge_values_explicit_h4( N, h, u, edge_val, h_neglect, answers_2018 ) dx = max(h_min, h(i) ) x(i+1) = x(i) + dx xavg = 0.5 * (x(i+1) + x(i)) - A(1,i) = dx - A(2,i) = dx * xavg - A(3,i) = dx * (xavg**2 + C1_12*dx**2) - A(4,i) = dx * xavg * (xavg**2 + 0.25*dx**2) - B(i) = u(i) * dx + A(1,i) = 1.0 + A(2,i) = xavg + A(3,i) = (xavg**2 + C1_12*dx**2) + A(4,i) = xavg * (xavg**2 + 0.25*dx**2) + B(i) = u(i) enddo call linear_solver( 4, A, B, C ) @@ -359,20 +359,16 @@ subroutine edge_values_explicit_h4( N, h, u, edge_val, h_neglect, answers_2018 ) ! system that sets the origin at the last interface in the domain. h_min = hMinFrac * ((h(N-3) + h(N-2)) + (h(N-1) + h(N))) if (h_min == 0.0) h_min = 1.0 ! Handle the case of all massless layers. - x(1) = 0.0 - do i=1,4 dx = max(h_min, h(N+1-i) ) x(i+1) = x(i) + dx xavg = x(i) + 0.5*dx - - A(1,i) = dx - A(2,i) = dx * xavg - A(3,i) = dx * (xavg**2 + C1_12*dx**2) - A(4,i) = dx * xavg * (xavg**2 + 0.25*dx**2) - - B(i) = u(N+1-i) * dx + A(1,i) = 1.0 + A(2,i) = xavg + A(3,i) = (xavg**2 + C1_12*dx**2) + A(4,i) = xavg * (xavg**2 + 0.25*dx**2) + B(i) = u(N+1-i) enddo call linear_solver( 4, A, B, C ) @@ -524,11 +520,11 @@ subroutine edge_values_implicit_h4( N, h, u, edge_val, h_neglect, answers_2018 ) dx = max(h_min, h(i) ) x(i+1) = x(i) + dx xavg = x(i) + 0.5*dx - Asys(1,i) = dx - Asys(2,i) = dx * xavg - Asys(3,i) = dx * (xavg**2 + C1_12*dx**2) - Asys(4,i) = dx * xavg * (xavg**2 + 0.25*dx**2) - Bsys(i) = u(i) * dx + Asys(1,i) = 1.0 + Asys(2,i) = xavg + Asys(3,i) = (xavg**2 + C1_12*dx**2) + Asys(4,i) = xavg * (xavg**2 + 0.25*dx**2) + Bsys(i) = u(i) enddo call linear_solver( 4, Asys, Bsys, Csys ) @@ -564,13 +560,11 @@ subroutine edge_values_implicit_h4( N, h, u, edge_val, h_neglect, answers_2018 ) dx = max(h_min, h(N+1-i) ) x(i+1) = x(i) + dx xavg = x(i) + 0.5*dx - - Asys(1,i) = dx - Asys(2,i) = dx * xavg - Asys(3,i) = dx * (xavg**2 + C1_12*dx**2) - Asys(4,i) = dx * xavg * (xavg**2 + 0.25*dx**2) - - Bsys(i) = u(N+1-i) * dx + Asys(1,i) = 1.0 + Asys(2,i) = xavg + Asys(3,i) = (xavg**2 + C1_12*dx**2) + Asys(4,i) = xavg * (xavg**2 + 0.25*dx**2) + Bsys(i) = u(N+1-i) enddo call linear_solver( 4, Asys, Bsys, Csys ) @@ -644,8 +638,9 @@ subroutine edge_values_implicit_h6( N, h, u, edge_val, h_neglect, answers_2018 ) ! Local variables integer :: i, j, k ! loop indexes real :: h0, h1, h2, h3 ! cell widths [H] - real :: g, g_2, g_3 ! the following are - real :: g_4, g_5, g_6 ! auxiliary variables + real :: hMin ! The minimum thickness used in these calculations [H] + real :: h01, h01_2, h01_3, h01_4, h01_5, h01_6 ! Summed thicknesses to various powers [H^n ~> m^n or kg^n m-2n] + real :: h23, h23_2, h23_3, h23_4, h23_5, h23_6 ! Summed thicknesses to various powers [H^n ~> m^n or kg^n m-2n] real :: d2, d3, d4, d5, d6 ! to set up the systems real :: n2, n3, n4, n5, n6 ! used to compute the real :: h1_2, h2_2 ! the coefficients of the @@ -658,6 +653,7 @@ subroutine edge_values_implicit_h6( N, h, u, edge_val, h_neglect, answers_2018 ) real :: h2ph3, h2ph3_2 ! ... real :: h2ph3_3, h2ph3_4 ! ... real :: h0ph1_5, h2ph3_5 ! ... + real :: I_h1ph2 ! The inverse of the sum of two layers' thicknesses [H] real :: alpha, beta ! stencil coefficients real :: a, b, c, d ! " real, dimension(7) :: x ! Coordinate system with 0 at edges [same units as h] @@ -678,6 +674,7 @@ subroutine edge_values_implicit_h6( N, h, u, edge_val, h_neglect, answers_2018 ) hNeglect = hNeglect_edge_dflt ; if (present(h_neglect)) hNeglect = h_neglect ! Loop on cells (except last one) + ! Loop on interior cells do k = 2,N-2 ! Cell widths @@ -688,11 +685,11 @@ subroutine edge_values_implicit_h6( N, h, u, edge_val, h_neglect, answers_2018 ) ! Avoid singularities when h0=0 or h3=0 if (h0*h3==0.) then - g = max( hNeglect, h0+h1+h2+h3 ) - h0 = max( hMinFrac*g, h0 ) - h1 = max( hMinFrac*g, h1 ) - h2 = max( hMinFrac*g, h2 ) - h3 = max( hMinFrac*g, h3 ) + hMin = hMinFrac * max( hNeglect, h0+h1+h2+h3 ) + h0 = max( hMin, h0 ) + h1 = max( hMin, h1 ) + h2 = max( hMin, h2 ) + h3 = max( hMin, h3 ) endif ! Auxiliary calculations @@ -708,31 +705,31 @@ subroutine edge_values_implicit_h6( N, h, u, edge_val, h_neglect, answers_2018 ) h2_5 = h2_3 * h2_2 h2_6 = h2_3 * h2_3 - g = h0 + h1 - g_2 = g * g - g_3 = g * g_2 - g_4 = g_2 * g_2 - g_5 = g_4 * g - g_6 = g_3 * g_3 - - d2 = ( h1_2 - g_2 ) / h0 - d3 = ( h1_3 - g_3 ) / h0 - d4 = ( h1_4 - g_4 ) / h0 - d5 = ( h1_5 - g_5 ) / h0 - d6 = ( h1_6 - g_6 ) / h0 - - g = h2 + h3 - g_2 = g * g - g_3 = g * g_2 - g_4 = g_2 * g_2 - g_5 = g_4 * g - g_6 = g_3 * g_3 - - n2 = ( g_2 - h2_2 ) / h3 - n3 = ( g_3 - h2_3 ) / h3 - n4 = ( g_4 - h2_4 ) / h3 - n5 = ( g_5 - h2_5 ) / h3 - n6 = ( g_6 - h2_6 ) / h3 + h01 = h0 + h1 + h01_2 = h01 * h01 + h01_3 = h01 * h01_2 + h01_4 = h01_2 * h01_2 + h01_5 = h01_4 * h01 + h01_6 = h01_3 * h01_3 + + d2 = ( h01_2 - h1_2 ) / h0 ! = (2.0*h1 + h0) + d3 = ( h01_3 - h1_3 ) / h0 ! = (3.0*h1_2 + h0*(3.0*h1 + h0)) + d4 = ( h01_4 - h1_4 ) / h0 ! = (4.0*h1_3 + h0*(6.0*h1_2 + h0*(4.0*h1 + h0))) + d5 = ( h01_5 - h1_5 ) / h0 ! = (5.0*h1_4 + h0*(10.0*h1_3 + h0*(10.0*h1_2 + h0*(5.0*h1 + h0)))) + d6 = ( h01_6 - h1_6 ) / h0 ! = (6.0*h1_5 + h0*(15.0*h1_4 + h0*(20.0*h1_3 + h0*(15.0*h1_2 + h0*(6.0*h1 + h0))))) + + h23 = h2 + h3 + h23_2 = h23 * h23 + h23_3 = h23 * h23_2 + h23_4 = h23_2 * h23_2 + h23_5 = h23_4 * h23 + h23_6 = h23_3 * h23_3 + + n2 = ( h23_2 - h2_2 ) / h3 ! = 2.0*h2 + h3 + n3 = ( h23_3 - h2_3 ) / h3 ! = 3.0*h2_2 + h3*(3.0*h2 + h3) + n4 = ( h23_4 - h2_4 ) / h3 ! = 4.0*h2_3 + h3*(6.0*h2_2 + h3*(4.0*h2 + h3)) + n5 = ( h23_5 - h2_5 ) / h3 ! = 5.0*h2_4 + h3*(10.0*h2_3 + h3*(10.0*h2_2 + h3*(5.0*h2 + h3))) + n6 = ( h23_6 - h2_6 ) / h3 ! = 6.0*h2_5 + h3*(15.0*h2_4 + h3*(20.0*h2_3 + h3*(15.0*h2_2 + h3*(6.0*h2 + h3)))) ! Compute matrix entries Asys(1,1) = 1.0 @@ -744,35 +741,35 @@ subroutine edge_values_implicit_h6( N, h, u, edge_val, h_neglect, answers_2018 ) Asys(2,1) = - h1 Asys(2,2) = h2 - Asys(2,3) = -0.5 * d2 + Asys(2,3) = 0.5 * d2 Asys(2,4) = 0.5 * h1 Asys(2,5) = -0.5 * h2 Asys(2,6) = -0.5 * n2 Asys(3,1) = 0.5 * h1_2 Asys(3,2) = 0.5 * h2_2 - Asys(3,3) = d3 / 6.0 + Asys(3,3) = -d3 / 6.0 Asys(3,4) = - h1_2 / 6.0 Asys(3,5) = - h2_2 / 6.0 Asys(3,6) = - n3 / 6.0 Asys(4,1) = - h1_3 / 6.0 Asys(4,2) = h2_3 / 6.0 - Asys(4,3) = - d4 / 24.0 + Asys(4,3) = d4 / 24.0 Asys(4,4) = h1_3 / 24.0 Asys(4,5) = - h2_3 / 24.0 Asys(4,6) = - n4 / 24.0 Asys(5,1) = h1_4 / 24.0 Asys(5,2) = h2_4 / 24.0 - Asys(5,3) = d5 / 120.0 + Asys(5,3) = -d5 / 120.0 Asys(5,4) = - h1_4 / 120.0 Asys(5,5) = - h2_4 / 120.0 Asys(5,6) = - n5 / 120.0 Asys(6,1) = - h1_5 / 120.0 Asys(6,2) = h2_5 / 120.0 - Asys(6,3) = - d6 / 720.0 + Asys(6,3) = d6 / 720.0 Asys(6,4) = h1_5 / 720.0 Asys(6,5) = - h2_5 / 720.0 Asys(6,6) = - n6 / 720.0 @@ -805,11 +802,11 @@ subroutine edge_values_implicit_h6( N, h, u, edge_val, h_neglect, answers_2018 ) ! Avoid singularities when h0=0 or h3=0 if (h0*h3==0.) then - g = max( hNeglect, h0+h1+h2+h3 ) - h0 = max( hMinFrac*g, h0 ) - h1 = max( hMinFrac*g, h1 ) - h2 = max( hMinFrac*g, h2 ) - h3 = max( hMinFrac*g, h3 ) + hMin = hMinFrac * max( hNeglect, h0+h1+h2+h3 ) + h0 = max( hMin, h0 ) + h1 = max( hMin, h1 ) + h2 = max( hMin, h2 ) + h3 = max( hMin, h3 ) endif ! Auxiliary calculations @@ -825,12 +822,27 @@ subroutine edge_values_implicit_h6( N, h, u, edge_val, h_neglect, answers_2018 ) h2_5 = h2_3 * h2_2 h2_6 = h2_3 * h2_3 - g = h0 + h1 - g_2 = g * g - g_3 = g * g_2 - g_4 = g_2 * g_2 - g_5 = g_4 * g - g_6 = g_3 * g_3 + h01 = h0 + h1 ; h01_2 = h01 * h01 ; h01_3 = h01 * h01_2 + h01_4 = h01_2 * h01_2 ; h01_5 = h01_4 * h01 ; h01_6 = h01_3 * h01_3 + + d2 = ( h01_2 - h1_2 ) / h0 ! = (2.0*h1 + h0) + d3 = ( h01_3 - h1_3 ) / h0 ! = (3.0*h1_2 + h0*(3.0*h1 + h0)) + d4 = ( h01_4 - h1_4 ) / h0 ! = (4.0*h1_3 + h0*(6.0*h1_2 + h0*(4.0*h1 + h0))) + d5 = ( h01_5 - h1_5 ) / h0 ! = (5.0*h1_4 + h0*(10.0*h1_3 + h0*(10.0*h1_2 + h0*(5.0*h1 + h0)))) + d6 = ( h01_6 - h1_6 ) / h0 ! = (6.0*h1_5 + h0*(15.0*h1_4 + h0*(20.0*h1_3 + h0*(15.0*h1_2 + h0*(6.0*h1 + h0))))) + + h23 = h2 + h3 + h23_2 = h23 * h23 + h23_3 = h23 * h23_2 + h23_4 = h23_2 * h23_2 + h23_5 = h23_4 * h23 + h23_6 = h23_3 * h23_3 + + n2 = ( h23_2 - h2_2 ) / h3 ! = 2.0*h2 + h3 + n3 = ( h23_3 - h2_3 ) / h3 ! = 3.0*h2_2 + h3*(3.0*h2 + h3) + n4 = ( h23_4 - h2_4 ) / h3 ! = 4.0*h2_3 + h3*(6.0*h2_2 + h3*(4.0*h2 + h3)) + n5 = ( h23_5 - h2_5 ) / h3 ! = 5.0*h2_4 + h3*(10.0*h2_3 + h3*(10.0*h2_2 + h3*(5.0*h2 + h3))) + n6 = ( h23_6 - h2_6 ) / h3 ! = 6.0*h2_5 + h3*(15.0*h2_4 + h3*(20.0*h2_3 + h3*(15.0*h2_2 + h3*(6.0*h2 + h3)))) h0ph1 = h0 + h1 h0ph1_2 = h0ph1 * h0ph1 @@ -838,25 +850,6 @@ subroutine edge_values_implicit_h6( N, h, u, edge_val, h_neglect, answers_2018 ) h0ph1_4 = h0ph1_2 * h0ph1_2 h0ph1_5 = h0ph1_3 * h0ph1_2 - d2 = ( h1_2 - g_2 ) / h0 - d3 = ( h1_3 - g_3 ) / h0 - d4 = ( h1_4 - g_4 ) / h0 - d5 = ( h1_5 - g_5 ) / h0 - d6 = ( h1_6 - g_6 ) / h0 - - g = h2 + h3 - g_2 = g * g - g_3 = g * g_2 - g_4 = g_2 * g_2 - g_5 = g_4 * g - g_6 = g_3 * g_3 - - n2 = ( g_2 - h2_2 ) / h3 - n3 = ( g_3 - h2_3 ) / h3 - n4 = ( g_4 - h2_4 ) / h3 - n5 = ( g_5 - h2_5 ) / h3 - n6 = ( g_6 - h2_6 ) / h3 - ! Compute matrix entries Asys(1,1) = 1.0 Asys(1,2) = 1.0 @@ -867,35 +860,35 @@ subroutine edge_values_implicit_h6( N, h, u, edge_val, h_neglect, answers_2018 ) Asys(2,1) = - h0ph1 Asys(2,2) = 0.0 - Asys(2,3) = -0.5 * d2 + Asys(2,3) = 0.5 * d2 Asys(2,4) = 0.5 * h1 Asys(2,5) = -0.5 * h2 Asys(2,6) = -0.5 * n2 Asys(3,1) = 0.5 * h0ph1_2 Asys(3,2) = 0.0 - Asys(3,3) = d3 / 6.0 + Asys(3,3) = -d3 / 6.0 Asys(3,4) = - h1_2 / 6.0 Asys(3,5) = - h2_2 / 6.0 Asys(3,6) = - n3 / 6.0 Asys(4,1) = - h0ph1_3 / 6.0 Asys(4,2) = 0.0 - Asys(4,3) = - d4 / 24.0 + Asys(4,3) = d4 / 24.0 Asys(4,4) = h1_3 / 24.0 Asys(4,5) = - h2_3 / 24.0 Asys(4,6) = - n4 / 24.0 Asys(5,1) = h0ph1_4 / 24.0 Asys(5,2) = 0.0 - Asys(5,3) = d5 / 120.0 + Asys(5,3) = -d5 / 120.0 Asys(5,4) = - h1_4 / 120.0 Asys(5,5) = - h2_4 / 120.0 Asys(5,6) = - n5 / 120.0 Asys(6,1) = - h0ph1_5 / 120.0 Asys(6,2) = 0.0 - Asys(6,3) = - d6 / 720.0 + Asys(6,3) = d6 / 720.0 Asys(6,4) = h1_5 / 720.0 Asys(6,5) = - h2_5 / 720.0 Asys(6,6) = - n6 / 720.0 @@ -906,38 +899,32 @@ subroutine edge_values_implicit_h6( N, h, u, edge_val, h_neglect, answers_2018 ) alpha = Csys(1) beta = Csys(2) - a = Csys(3) - b = Csys(4) - c = Csys(5) - d = Csys(6) tri_l(2) = alpha tri_d(2) = 1.0 tri_u(2) = beta - tri_b(2) = a * u(1) + b * u(2) + c * u(3) + d * u(4) + tri_b(2) = Csys(3) * u(1) + Csys(4) * u(2) + Csys(5) * u(3) + Csys(6) * u(4) ! Boundary conditions: left boundary -! h_sum = (h(1) + h(2)) + (h(5) + h(6)) + (h(3) + h(4)) - g = max( hNeglect, hMinFrac*sum(h(1:6)) ) +! h_min = hMinFrac * ((h(1) + h(2)) + (h(5) + h(6)) + (h(3) + h(4))) + hMin = max( hNeglect, hMinFrac*sum(h(1:6)) ) x(1) = 0.0 - do i = 2,7 - x(i) = x(i-1) + max( g, h(i-1) ) - enddo - do i = 1,6 - dx = max( g, h(i) ) + dx = max( hMin, h(i) ) + x(i+1) = x(i) + dx if (use_2018_answers) then do j = 1,6 ; Asys(i,j) = ( (x(i+1)**j) - (x(i)**j) ) / j ; enddo + Bsys(i) = u(i) * dx else ! Use expressions with less sensitivity to roundoff xavg = 0.5 * (x(i+1) + x(i)) - Asys(i,1) = dx - Asys(i,2) = dx * xavg - Asys(i,3) = dx * (xavg**2 + C1_12*dx**2) - Asys(i,4) = dx * xavg * (xavg**2 + 0.25*dx**2) - Asys(i,5) = dx * (xavg**4 + 0.5*xavg**2*dx**2 + 0.0125*dx**4) - Asys(i,6) = dx * xavg * (xavg**4 + C5_6*xavg**2*dx**2 + 0.0625*dx**4) + Asys(i,1) = 1.0 + Asys(i,2) = xavg + Asys(i,3) = (xavg**2 + C1_12*dx**2) + Asys(i,4) = xavg * (xavg**2 + 0.25*dx**2) + Asys(i,5) = (xavg**4 + 0.5*xavg**2*dx**2 + 0.0125*dx**4) + Asys(i,6) = xavg * (xavg**4 + C5_6*xavg**2*dx**2 + 0.0625*dx**4) + Bsys(i) = u(i) endif - Bsys(i) = u(i) * dx enddo @@ -958,11 +945,11 @@ subroutine edge_values_implicit_h6( N, h, u, edge_val, h_neglect, answers_2018 ) ! Avoid singularities when h0=0 or h3=0 if (h0*h3==0.) then - g = max( hNeglect, h0+h1+h2+h3 ) - h0 = max( hMinFrac*g, h0 ) - h1 = max( hMinFrac*g, h1 ) - h2 = max( hMinFrac*g, h2 ) - h3 = max( hMinFrac*g, h3 ) + hMin = hMinFrac * max( hNeglect, h0+h1+h2+h3 ) + h0 = max( hMin, h0 ) + h1 = max( hMin, h1 ) + h2 = max( hMin, h2 ) + h3 = max( hMin, h3 ) endif ! Auxiliary calculations @@ -978,12 +965,31 @@ subroutine edge_values_implicit_h6( N, h, u, edge_val, h_neglect, answers_2018 ) h2_5 = h2_3 * h2_2 h2_6 = h2_3 * h2_3 - g = h0 + h1 - g_2 = g * g - g_3 = g * g_2 - g_4 = g_2 * g_2 - g_5 = g_4 * g - g_6 = g_3 * g_3 + h01 = h0 + h1 + h01_2 = h01 * h01 + h01_3 = h01 * h01_2 + h01_4 = h01_2 * h01_2 + h01_5 = h01_4 * h01 + h01_6 = h01_3 * h01_3 + + d2 = ( h01_2 - h1_2 ) / h0 ! = (2.0*h1 + h0) + d3 = ( h01_3 - h1_3 ) / h0 ! = (3.0*h1_2 + h0*(3.0*h1 + h0)) + d4 = ( h01_4 - h1_4 ) / h0 ! = (4.0*h1_3 + h0*(6.0*h1_2 + h0*(4.0*h1 + h0))) + d5 = ( h01_5 - h1_5 ) / h0 ! = (5.0*h1_4 + h0*(10.0*h1_3 + h0*(10.0*h1_2 + h0*(5.0*h1 + h0)))) + d6 = ( h01_6 - h1_6 ) / h0 ! = (6.0*h1_5 + h0*(15.0*h1_4 + h0*(20.0*h1_3 + h0*(15.0*h1_2 + h0*(6.0*h1 + h0))))) + + h23 = h2 + h3 + h23_2 = h23 * h23 + h23_3 = h23 * h23_2 + h23_4 = h23_2 * h23_2 + h23_5 = h23_4 * h23 + h23_6 = h23_3 * h23_3 + + n2 = ( h23_2 - h2_2 ) / h3 ! = 2.0*h2 + h3 + n3 = ( h23_3 - h2_3 ) / h3 ! = 3.0*h2_2 + h3*(3.0*h2 + h3) + n4 = ( h23_4 - h2_4 ) / h3 ! = 4.0*h2_3 + h3*(6.0*h2_2 + h3*(4.0*h2 + h3)) + n5 = ( h23_5 - h2_5 ) / h3 ! = 5.0*h2_4 + h3*(10.0*h2_3 + h3*(10.0*h2_2 + h3*(5.0*h2 + h3))) + n6 = ( h23_6 - h2_6 ) / h3 ! = 6.0*h2_5 + h3*(15.0*h2_4 + h3*(20.0*h2_3 + h3*(15.0*h2_2 + h3*(6.0*h2 + h3)))) h2ph3 = h2 + h3 h2ph3_2 = h2ph3 * h2ph3 @@ -991,25 +997,6 @@ subroutine edge_values_implicit_h6( N, h, u, edge_val, h_neglect, answers_2018 ) h2ph3_4 = h2ph3_2 * h2ph3_2 h2ph3_5 = h2ph3_3 * h2ph3_2 - d2 = ( h1_2 - g_2 ) / h0 - d3 = ( h1_3 - g_3 ) / h0 - d4 = ( h1_4 - g_4 ) / h0 - d5 = ( h1_5 - g_5 ) / h0 - d6 = ( h1_6 - g_6 ) / h0 - - g = h2 + h3 - g_2 = g * g - g_3 = g * g_2 - g_4 = g_2 * g_2 - g_5 = g_4 * g - g_6 = g_3 * g_3 - - n2 = ( g_2 - h2_2 ) / h3 - n3 = ( g_3 - h2_3 ) / h3 - n4 = ( g_4 - h2_4 ) / h3 - n5 = ( g_5 - h2_5 ) / h3 - n6 = ( g_6 - h2_6 ) / h3 - ! Compute matrix entries Asys(1,1) = 1.0 Asys(1,2) = 1.0 @@ -1020,35 +1007,35 @@ subroutine edge_values_implicit_h6( N, h, u, edge_val, h_neglect, answers_2018 ) Asys(2,1) = 0.0 Asys(2,2) = h2ph3 - Asys(2,3) = -0.5 * d2 + Asys(2,3) = 0.5 * d2 Asys(2,4) = 0.5 * h1 Asys(2,5) = -0.5 * h2 Asys(2,6) = -0.5 * n2 Asys(3,1) = 0.0 Asys(3,2) = 0.5 * h2ph3_2 - Asys(3,3) = d3 / 6.0 + Asys(3,3) = -d3 / 6.0 Asys(3,4) = - h1_2 / 6.0 Asys(3,5) = - h2_2 / 6.0 Asys(3,6) = - n3 / 6.0 Asys(4,1) = 0.0 Asys(4,2) = h2ph3_3 / 6.0 - Asys(4,3) = - d4 / 24.0 + Asys(4,3) = d4 / 24.0 Asys(4,4) = h1_3 / 24.0 Asys(4,5) = - h2_3 / 24.0 Asys(4,6) = - n4 / 24.0 Asys(5,1) = 0.0 Asys(5,2) = h2ph3_4 / 24.0 - Asys(5,3) = d5 / 120.0 + Asys(5,3) = - d5 / 120.0 Asys(5,4) = - h1_4 / 120.0 Asys(5,5) = - h2_4 / 120.0 Asys(5,6) = - n5 / 120.0 Asys(6,1) = 0.0 Asys(6,2) = h2ph3_5 / 120.0 - Asys(6,3) = - d6 / 720.0 + Asys(6,3) = d6 / 720.0 Asys(6,4) = h1_5 / 720.0 Asys(6,5) = - h2_5 / 720.0 Asys(6,6) = - n6 / 720.0 @@ -1071,26 +1058,24 @@ subroutine edge_values_implicit_h6( N, h, u, edge_val, h_neglect, answers_2018 ) ! Boundary conditions: right boundary ! h_sum = (h(N-3) + h(N-2)) + ((h(N-1) + h(N)) + (h(N-5) + h(N-4))) - g = max( hNeglect, hMinFrac*sum(h(N-5:N)) ) + hMin = max( hNeglect, hMinFrac*sum(h(N-5:N)) ) x(1) = 0.0 - do i = 2,7 - x(i) = x(i-1) + max( g, h(N-7+i) ) - enddo - do i = 1,6 - dx = max( g, h(N-6+i) ) + dx = max( hMin, h(N-6+i) ) + x(i+1) = x(i) + dx if (use_2018_answers) then do j = 1,6 ; Asys(i,j) = ( (x(i+1)**j) - (x(i)**j) ) / j ; enddo + Bsys(i) = u(N-6+i) * dx else ! Use expressions with less sensitivity to roundoff xavg = 0.5 * (x(i+1) + x(i)) - Asys(i,1) = dx - Asys(i,2) = dx * xavg - Asys(i,3) = dx * (xavg**2 + C1_12*dx**2) - Asys(i,4) = dx * xavg * (xavg**2 + 0.25*dx**2) - Asys(i,5) = dx * (xavg**4 + 0.5*xavg**2*dx**2 + 0.0125*dx**4) - Asys(i,6) = dx * xavg * (xavg**4 + C5_6*xavg**2*dx**2 + 0.0625*dx**4) + Asys(i,1) = 1.0 + Asys(i,2) = xavg + Asys(i,3) = (xavg**2 + C1_12*dx**2) + Asys(i,4) = xavg * (xavg**2 + 0.25*dx**2) + Asys(i,5) = (xavg**4 + 0.5*xavg**2*dx**2 + 0.0125*dx**4) + Asys(i,6) = xavg * (xavg**4 + C5_6*xavg**2*dx**2 + 0.0625*dx**4) + Bsys(i) = u(N-6+i) endif - Bsys(i) = u(N-6+i) * dx enddo From b598a2d102739787acfee89115b9b84203e97d9d Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Tue, 7 Jan 2020 00:10:54 -0500 Subject: [PATCH 021/316] Flag to reproduce old incorrect GM work Added a flag to reproduce the old GM work calculation in the top layer with the incorrect sign. The flag is currently enabled on default, which uses the old incorrect expression. --- .../lateral/MOM_thickness_diffuse.F90 | 20 +++++++++++++++---- 1 file changed, 16 insertions(+), 4 deletions(-) diff --git a/src/parameterizations/lateral/MOM_thickness_diffuse.F90 b/src/parameterizations/lateral/MOM_thickness_diffuse.F90 index 29b91e08aa..a79e6e1e82 100644 --- a/src/parameterizations/lateral/MOM_thickness_diffuse.F90 +++ b/src/parameterizations/lateral/MOM_thickness_diffuse.F90 @@ -72,6 +72,8 @@ module MOM_thickness_diffuse logical :: Use_KH_in_MEKE !< If true, uses the thickness diffusivity calculated here to diffuse MEKE. logical :: GM_src_alt !< If true, use the GM energy conversion form S^2*N^2*kappa rather !! than the streamfunction for the GM source term. + logical :: use_GM_work_bug !< If true, use the incorrect sign for the + !! top-level work tendency on the top layer. type(diag_ctrl), pointer :: diag => NULL() !< structure used to regulate timing of diagnostics real, pointer :: GMwork(:,:) => NULL() !< Work by thickness diffusivity [R Z L2 T-3 ~> W m-2] real, pointer :: diagSlopeX(:,:,:) => NULL() !< Diagnostic: zonal neutral slope [nondim] @@ -1235,10 +1237,15 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV drdiB = drho_dT_u(I) * (T(i+1,j,1)-T(i,j,1)) + & drho_dS_u(I) * (S(i+1,j,1)-S(i,j,1)) endif - Work_u(I,j) = Work_u(I,j) - G_scale * & - ( (uhD(I,j,1) * drdiB) * 0.25 * & - ((e(i,j,1) + e(i,j,2)) + (e(i+1,j,1) + e(i+1,j,2))) ) - + if (CS%use_GM_work_bug) then + Work_u(I,j) = Work_u(I,j) + G_scale * & + ( (uhD(I,j,1) * drdiB) * 0.25 * & + ((e(i,j,1) + e(i,j,2)) + (e(i+1,j,1) + e(i+1,j,2))) ) + else + Work_u(I,j) = Work_u(I,j) - G_scale * & + ( (uhD(I,j,1) * drdiB) * 0.25 * & + ((e(i,j,1) + e(i,j,2)) + (e(i+1,j,1) + e(i+1,j,2))) ) + endif enddo enddo @@ -1869,6 +1876,11 @@ subroutine thickness_diffuse_init(Time, G, GV, US, param_file, diag, CDp, CS) "If true, use the GM+E backscatter scheme in association \n"//& "with the Gent and McWilliams parameterization.", default=.false.) + call get_param(param_file, mdl, "USE_GM_WORK_BUG", CS%use_GM_work_bug, & + "If true, compute the top-layer work tendency on the u-grid " // & + "with the incorrect sign, for legacy reproducibility.", & + default=.true.) + if (CS%use_GME_thickness_diffuse) then call safe_alloc_ptr(CS%KH_u_GME,G%IsdB,G%IedB,G%jsd,G%jed,G%ke+1) call safe_alloc_ptr(CS%KH_v_GME,G%isd,G%ied,G%JsdB,G%JedB,G%ke+1) From 6dbecaac707e10bce015b3489ecf2083aaf82fd2 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Mon, 13 Jan 2020 15:20:39 -0500 Subject: [PATCH 022/316] (*)Added explicit boundary edge value estimates Use explicit expressions for the 4th order boundary edge value estimates when REMAPPING_2018_ANSWERS is false. These new expressions will never encounter zero pivots inside of linear equation solvers. These are mathematically equivalent to the previous expressions, but because they use only sign-definite expressions and extensive algebraic manipulation, answers can change, especially for very different layer thicknessees near the edges. By default all answers are bitwise identical. --- src/ALE/regrid_edge_values.F90 | 223 +++++++++++++++++++++++++-------- 1 file changed, 173 insertions(+), 50 deletions(-) diff --git a/src/ALE/regrid_edge_values.F90 b/src/ALE/regrid_edge_values.F90 index fd99b5aff6..c2e9f5f04d 100644 --- a/src/ALE/regrid_edge_values.F90 +++ b/src/ALE/regrid_edge_values.F90 @@ -3,6 +3,7 @@ module regrid_edge_values ! This file is part of MOM6. See LICENSE.md for the license. +use MOM_error_handler, only : MOM_error, FATAL use regrid_solvers, only : solve_linear_system, solve_tridiagonal_system use regrid_solvers, only : solve_diag_dominant_tridiag, linear_solver use polynomial_functions, only : evaluation_polynomial @@ -237,6 +238,8 @@ subroutine edge_values_explicit_h4( N, h, u, edge_val, h_neglect, answers_2018 ) real :: f1, f2, f3 ! auxiliary variables with various units real :: et1, et2, et3 ! terms the expresson for edge values [A H] real, dimension(5) :: x ! Coordinate system with 0 at edges [H] + real, dimension(4) :: dz ! A temporary array of limited layer thicknesses [H] + real, dimension(4) :: u_tmp ! A temporary array of cell average properties [A] real, parameter :: C1_12 = 1.0 / 12.0 real :: dx, xavg ! Differences and averages of successive values of x [same units as h] real, dimension(4,4) :: A ! values near the boundaries @@ -317,23 +320,16 @@ subroutine edge_values_explicit_h4( N, h, u, edge_val, h_neglect, answers_2018 ) else ! Use expressions with less sensitivity to roundoff h_min = hMinFrac*((h(1) + h(2)) + (h(3) + h(4))) if (h_min == 0.0) h_min = 1.0 ! Handle the case of all massless layers. - x(1) = 0.0 - do i = 1,4 - dx = max(h_min, h(i) ) - x(i+1) = x(i) + dx - xavg = 0.5 * (x(i+1) + x(i)) - A(1,i) = 1.0 - A(2,i) = xavg - A(3,i) = (xavg**2 + C1_12*dx**2) - A(4,i) = xavg * (xavg**2 + 0.25*dx**2) - B(i) = u(i) - enddo - call linear_solver( 4, A, B, C ) + do i=1,4 + dz(i) = max(h_min, h(i) ) + u_tmp(i) = u(i) + enddo + call end_value_h4(dz, u_tmp, C) ! Set the edge values of the first cell - edge_val(1,1) = C(1) ! x(1) = 0 so ignore + x(1)*(C(2) + x(1)*(C(3) + x(1)*C(4))) - edge_val(1,2) = C(1) + x(2)*(C(2) + x(2)*(C(3) + x(2)*C(4))) + edge_val(1,1) = C(1) + edge_val(1,2) = C(1) + dz(1)*(C(2) + dz(1)*(C(3) + dz(1)*C(4))) endif edge_val(2,1) = edge_val(1,2) @@ -359,23 +355,15 @@ subroutine edge_values_explicit_h4( N, h, u, edge_val, h_neglect, answers_2018 ) ! system that sets the origin at the last interface in the domain. h_min = hMinFrac * ((h(N-3) + h(N-2)) + (h(N-1) + h(N))) if (h_min == 0.0) h_min = 1.0 ! Handle the case of all massless layers. - x(1) = 0.0 do i=1,4 - dx = max(h_min, h(N+1-i) ) - x(i+1) = x(i) + dx - xavg = x(i) + 0.5*dx - A(1,i) = 1.0 - A(2,i) = xavg - A(3,i) = (xavg**2 + C1_12*dx**2) - A(4,i) = xavg * (xavg**2 + 0.25*dx**2) - B(i) = u(N+1-i) + dz(i) = max(h_min, h(N+1-i) ) + u_tmp(i) = u(N+1-i) enddo - - call linear_solver( 4, A, B, C ) + call end_value_h4(dz, u_tmp, C) ! Set the last and second to last edge values edge_val(N,2) = C(1) - edge_val(N,1) = C(1) + x(2)*(C(2) + x(2)*(C(3) + x(2)*C(4))) + edge_val(N,1) = C(1) + dz(1)*(C(2) + dz(1)*(C(3) + dz(1)*C(4))) endif edge_val(N-1,2) = edge_val(N,1) @@ -418,7 +406,7 @@ subroutine edge_values_implicit_h4( N, h, u, edge_val, h_neglect, answers_2018 ) ! Local variables integer :: i, j ! loop indexes - real :: h0, h1 ! cell widths [H] + real :: h0, h1, h2 ! cell widths [H] real :: h_min ! A minimal cell width [H] real :: h_sum ! A sum of adjacent thicknesses [H] real :: h0_2, h1_2, h0h1 @@ -428,9 +416,14 @@ subroutine edge_values_implicit_h4( N, h, u, edge_val, h_neglect, answers_2018 ) real :: a, b real, dimension(5) :: x ! Coordinate system with 0 at edges [H] real, parameter :: C1_12 = 1.0 / 12.0 + real, parameter :: C1_3 = 1.0 / 3.0 + real, dimension(4) :: dz ! A temporary array of limited layer thicknesses [H] + real, dimension(4) :: u_tmp ! A temporary array of cell average properties [A] real :: dx, xavg ! Differences and averages of successive values of x [H] real, dimension(4,4) :: Asys ! boundary conditions real, dimension(4) :: Bsys, Csys + real, dimension(4,4) :: Asys_orig ! boundary conditions + real, dimension(4) :: Bsys_orig real, dimension(N+1) :: tri_l, & ! tridiagonal system (lower diagonal) [nondim] tri_d, & ! tridiagonal system (middle diagonal) [nondim] tri_c, & ! tridiagonal system central value, with tri_d = tri_c+tri_l+tri_u @@ -515,21 +508,14 @@ subroutine edge_values_implicit_h4( N, h, u, edge_val, h_neglect, answers_2018 ) tri_d(1) = 1.0 else ! Use expressions with less sensitivity to roundoff h_min = max( hNeglect, hMinFrac * ((h(1) + h(2)) + (h(3) + h(4))) ) - x(1) = 0.0 - do i = 1,4 - dx = max(h_min, h(i) ) - x(i+1) = x(i) + dx - xavg = x(i) + 0.5*dx - Asys(1,i) = 1.0 - Asys(2,i) = xavg - Asys(3,i) = (xavg**2 + C1_12*dx**2) - Asys(4,i) = xavg * (xavg**2 + 0.25*dx**2) - Bsys(i) = u(i) + do i=1,4 + dz(i) = max(h_min, h(i) ) + u_tmp(i) = u(i) enddo + call end_value_h4(dz, u_tmp, Csys) - call linear_solver( 4, Asys, Bsys, Csys ) + tri_b(1) = Csys(1) ! Set the first edge value. - tri_b(1) = Csys(1) ! Set the first edge value, using the fact that x(1) = 0. tri_c(1) = 1.0 endif tri_u(1) = 0.0 ! tri_l(1) = 0.0 @@ -555,19 +541,12 @@ subroutine edge_values_implicit_h4( N, h, u, edge_val, h_neglect, answers_2018 ) ! Use expressions with less sensitivity to roundoff, including using a coordinate ! system that sets the origin at the last interface in the domain. h_min = max( hNeglect, hMinFrac * ((h(N-3) + h(N-2)) + (h(N-1) + h(N))) ) - x(1) = 0.0 do i=1,4 - dx = max(h_min, h(N+1-i) ) - x(i+1) = x(i) + dx - xavg = x(i) + 0.5*dx - Asys(1,i) = 1.0 - Asys(2,i) = xavg - Asys(3,i) = (xavg**2 + C1_12*dx**2) - Asys(4,i) = xavg * (xavg**2 + 0.25*dx**2) - Bsys(i) = u(N+1-i) + dz(i) = max(h_min, h(N+1-i) ) + u_tmp(i) = u(N+1-i) enddo - call linear_solver( 4, Asys, Bsys, Csys ) + call end_value_h4(dz, u_tmp, Csys) ! Set the last edge value tri_b(N+1) = Csys(1) @@ -591,6 +570,118 @@ subroutine edge_values_implicit_h4( N, h, u, edge_val, h_neglect, answers_2018 ) end subroutine edge_values_implicit_h4 +!> Determine a one-sided 4th order polynomial fit of u to the data points for the purposes of specifying +!! edge values, as described in the appendix of White and Adcroft JCP 2008. +subroutine end_value_h4(dz, u, Csys) + real, dimension(4), intent(in) :: dz !< The thicknesses of 4 layers, starting at the edge [H]. + !! The values of dz must be positive. + real, dimension(4), intent(in) :: u !< The average properties of 4 layers, starting at the edge [A] + real, dimension(4), intent(out) :: Csys !< The four coefficients of a 4th order polynomial fit + !! of u as a function of z [A H-(n-1)] + + ! Local variables + real :: Wt(3,4) ! The weights of successive u differences in the 4 closed form expressions. + ! The units of Wt vary with the second index as [H-(n-1)]. + real :: h1, h2, h3, h4 ! Copies of the layer thicknesses [H] + real :: h12, h23, h34 ! Sums of two successive thicknesses [H] + real :: h123, h234 ! Sums of three successive thicknesses [H] + real :: h1234 ! Sums of all four thicknesses [H] + ! real :: I_h1 ! The inverse of the a thickness [H-1] + real :: I_h12, I_h23, I_h34 ! The inverses of sums of two thicknesses [H-1] + real :: I_h123, I_h234 ! The inverse of the sum of three thicknesses [H-1] + real :: I_h1234 ! The inverse of the sum of all four thicknesses [H-1] + real :: I_denom ! The inverse of the denominator some expressions [H-3] + real :: I_denB3 ! The inverse of the product of three sums of thicknesses [H-3] + real, parameter :: C1_3 = 1.0 / 3.0 + integer :: i, j, k + + ! These are only used for code verification + real, dimension(4) :: Atest ! The coefficients of an expression that is being tested. + real :: zavg, u_mag, c_mag + character(len=128) :: mesg + real, parameter :: C1_12 = 1.0 / 12.0 + + ! if ((dz(1) == dz(2)) .and. (dz(1) == dz(3)) .and. (dz(1) == dz(4))) then + ! ! There are simple closed-form expressions in this case + ! I_h1 = 0.0 ; if (dz(1) > 0.0) I_h1 = 1.0 / dz(1) + ! Csys(1) = u(1) + (-13.0 * (u(2)-u(1)) + 10.0 * (u(3)-u(2)) - 3.0 * (u(4)-u(3))) * (0.25*C1_3) + ! Csys(2) = (35.0 * (u(2)-u(1)) - 34.0 * (u(3)-u(2)) + 11.0 * (u(4)-u(3))) * (0.25*C1_3 * I_h1) + ! Csys(3) = (-5.0 * (u(2)-u(1)) + 8.0 * (u(3)-u(2)) - 3.0 * (u(4)-u(3))) * (0.25 * I_h1**2) + ! Csys(4) = ((u(2)-u(1)) - 2.0 * (u(3)-u(2)) + (u(4)-u(3))) * (0.5*C1_3) + ! else + + ! Express the coefficients as sums of the differences between properties of succesive layers. + + h1 = dz(1) ; h2 = dz(2) ; h3 = dz(3) ; h4 = dz(4) + h12 = h1+h2 ; h23 = h2+h3 ; h34 = h3+h4 + h123 = h12 + h3 ; h234 = h2 + h34 ; h1234 = h12 + h34 + ! Find 3 reciprocals with a single division for efficiency. + I_denB3 = 1.0 / (h123 * h12 * h23) + I_h12 = (h123 * h23) * I_denB3 + I_h23 = (h12 * h123) * I_denB3 + I_h123 = (h12 * h23) * I_denB3 + I_denom = 1.0 / ( h1234 * (h234 * h34) ) + I_h34 = (h1234 * h234) * I_denom + I_h234 = (h1234 * h34) * I_denom + I_h1234 = (h234 * h34) * I_denom + + ! Calculation coefficients in the four equations + + ! The expressions for Csys(3) and Csys(4) come from reducing the 4x4 matrix problem into the following 2x2 + ! matrix problem, then manipulating the analytic solution to avoid any subtraction and simplifying. + ! (C1_3 * h123 * h23) * Csys(3) + (0.25 * h123 * h23 * (h3 + 2.0*h2 + 3.0*h1)) * Csys(4) = + ! (u(3)-u(1)) - (u(2)-u(1)) * (h12 + h23) * I_h12 + ! (C1_3 * ((h23 + h34) * h1234 + h23 * h3)) * Csys(3) + + ! (0.25 * ((h1234 + h123 + h12 + h1) * h23 * h3 + (h1234 + h12 + h1) * (h23 + h34) * h1234)) * Csys(4) = + ! (u(4)-u(1)) - (u(2)-u(1)) * (h123 + h234) * I_h12 + ! The final expressions for Csys(1) and Csys(2) were derived by algebraically manipulating the following expressions: + ! Csys(1) = (C1_3 * h1 * h12 * Csys(3) + 0.25 * h1 * h12 * (2.0*h1+h2) * Csys(4)) - & + ! (h1*I_h12)*(u(2)-u(1)) + u(1) + ! Csys(2) = (-2.0*C1_3 * (2.0*h1+h2) * Csys(3) - 0.5 * (h1**2 + h12 * (2.0*h1+h2)) * Csys(4)) + & + ! 2.0*I_h12 * (u(2)-u(1)) + ! These expressions are typically evaluated at x=0 and x=h1, so it is important that these are well behaved + ! for these values, suggesting that h1/h23 and h1/h34 should not be allowed to be too large. + + Wt(1,1) = -h1 * (I_h1234 + I_h123 + I_h12) ! > -3 + Wt(2,1) = h1 * h12 * ( I_h234 * I_h1234 + I_h23 * (I_h234 + I_h123) ) ! < (h1/h234) + (h1/h23)*(2+(h1/h234)) + Wt(3,1) = -h1 * h12 * h123 * I_denom ! > -(h1/h34)*(1+(h1/h234)) + + Wt(1,2) = 2.0 * (I_h12*(1.0 + (h1+h12) * (I_h1234 + I_h123)) + h1 * I_h1234*I_h123) ! < 10/h12 + Wt(2,2) = -2.0 * ((h1 * h12 * I_h1234) * (I_h23 * (I_h234 + I_h123)) + & ! > -(10+6*(h1/h234))/h23 + (h1+h12) * ( I_h1234*I_h234 + I_h23 * (I_h234 + I_h123) ) ) + Wt(3,2) = 2.0 * ((h1+h12) * h123 + h1*h12 ) * I_denom ! < (2+(6*h1/h234)) / h34 + + Wt(1,3) = -3.0 * I_h12 * I_h123* ( 1.0 + I_h1234 * ((h1+h12)+h123) ) ! > -12 / (h12*h123) + Wt(2,3) = 3.0 * I_h23 * ( I_h123 + I_h1234 * ((h1+h12)+h123) * (I_h123 + I_h234) ) ! < 12 / (h23^2) + Wt(3,3) = -3.0 * ((h1+h12)+h123) * I_denom ! > -9 / (h234*h23) + + Wt(1,4) = 4.0 * I_h1234 * I_h123 * I_h12 ! Wt*h1^3 < 4 + Wt(2,4) = -4.0 * I_h1234 * (I_h23 * (I_h123 + I_h234)) ! Wt*h1^3 > -4* (h1/h23)*(1+h1/h234) + Wt(3,4) = 4.0 * I_denom ! = 4.0*I_h1234 * I_h234 * I_h34 ! Wt*h1^3 < 4 * (h1/h234)*(h1/h34) + + Csys(1) = ((u(1) + Wt(1,1) * (u(2)-u(1))) + Wt(2,1) * (u(3)-u(2))) + Wt(3,1) * (u(4)-u(3)) + Csys(2) = (Wt(1,2) * (u(2)-u(1)) + Wt(2,2) * (u(3)-u(2))) + Wt(3,2) * (u(4)-u(3)) + Csys(3) = (Wt(1,3) * (u(2)-u(1)) + Wt(2,3) * (u(3)-u(2))) + Wt(3,3) * (u(4)-u(3)) + Csys(4) = (Wt(1,4) * (u(2)-u(1)) + Wt(2,4) * (u(3)-u(2))) + Wt(3,4) * (u(4)-u(3)) + + ! endif ! End of non-uniform layer thickness branch. + + ! To verify that these answers are correct, uncomment the following: +! u_mag = 0.0 ; do i=1,4 ; u_mag = max(u_mag, abs(u(i))) ; enddo +! do i = 1,4 +! if (i==1) then ; zavg = 0.5*dz(i) ; else ; zavg = zavg + 0.5*(dz(i-1)+dz(i)) ; endif +! Atest(1) = 1.0 +! Atest(2) = zavg ! = ( (z(i+1)**2) - (z(i)**2) ) / (2*dz(i)) +! Atest(3) = (zavg**2 + 0.25*C1_3*dz(i)**2) ! = ( (z(i+1)**3) - (z(i)**3) ) / (3*dz(i)) +! Atest(4) = zavg * (zavg**2 + 0.25*dz(i)**2) ! = ( (z(i+1)**4) - (z(i)**4) ) / (4*dz(i)) +! c_mag = 1.0 ; do k=0,3 ; do j=1,3 ; c_mag = c_mag + abs(Wt(j,k+1) * zavg**k) ; enddo ; enddo +! write(mesg, '("end_value_h4 line ", i2, " c_mag = ", es10.2, " u_mag = ", es10.2)') i, c_mag, u_mag +! call test_line(mesg, 4, Atest, Csys, u(i), u_mag*c_mag, tolerance=1.0e-15) +! enddo + +end subroutine end_value_h4 + + !> Compute ih6 edge values (implicit sixth order accurate) !! in the same units as h. !! @@ -653,7 +744,6 @@ subroutine edge_values_implicit_h6( N, h, u, edge_val, h_neglect, answers_2018 ) real :: h2ph3, h2ph3_2 ! ... real :: h2ph3_3, h2ph3_4 ! ... real :: h0ph1_5, h2ph3_5 ! ... - real :: I_h1ph2 ! The inverse of the sum of two layers' thicknesses [H] real :: alpha, beta ! stencil coefficients real :: a, b, c, d ! " real, dimension(7) :: x ! Coordinate system with 0 at edges [same units as h] @@ -1098,4 +1188,37 @@ subroutine edge_values_implicit_h6( N, h, u, edge_val, h_neglect, answers_2018 ) end subroutine edge_values_implicit_h6 + +! Verify that A*C = R to within roundoff. +subroutine test_line(msg, N, A, C, R, mag, tolerance) + integer, intent(in) :: N + real, dimension(4), intent(in) :: A + real, dimension(4), intent(in) :: C + real, intent(in) :: R + real, intent(in) :: mag !< The magnitude of leading order terms in this line + real, optional, intent(in) :: tolerance + character(len=*) :: msg + + real :: sum, sum_mag + real :: tol + character(len=128) :: mesg2 + integer :: i + + tol = 1.0e-12 ; if (present(tolerance)) tol = tolerance + + sum = 0.0 ; sum_mag = max(0.0,mag) + + do i=1,N + sum = sum + A(i) * C(i) + sum_mag = sum_mag + abs(A(i) * C(i)) + enddo + + if (abs(sum - R) > tol * (sum_mag + abs(R))) then + write(mesg2, '(", Fractional error = ", es12.4,", sum = ", es12.4)') (sum - R) / (sum_mag + abs(R)), sum + call MOM_error(FATAL, "Failed line test: "//trim(msg)//trim(mesg2)) + endif + +end subroutine test_line + + end module regrid_edge_values From 0a987cf34bfd89455ae2aff37bca5f7b3d901db0 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Mon, 13 Jan 2020 17:30:09 -0500 Subject: [PATCH 023/316] (*)Got a test working with edge_slopes_implicit_h5 Added relative thickness limits within edge_values_implicit_h6 and edge_slopes_implicit_h5 that enable them to run without crashing for the z and rho versions of flow_downslope testcase with REMAPPING_SCHEME = "PQM_IH6IH5". Also hard-coded the calls from these routines to solve_linear_solver to use updated versions of the solver. Because these routines had never been useful before, this does not change answers in any of the test cases. --- src/ALE/regrid_edge_slopes.F90 | 153 +++++++++++++++------------------ src/ALE/regrid_edge_values.F90 | 137 ++++++++++------------------- 2 files changed, 113 insertions(+), 177 deletions(-) diff --git a/src/ALE/regrid_edge_slopes.F90 b/src/ALE/regrid_edge_slopes.F90 index 3e31feb030..5bfb5b287a 100644 --- a/src/ALE/regrid_edge_slopes.F90 +++ b/src/ALE/regrid_edge_slopes.F90 @@ -282,8 +282,8 @@ subroutine edge_slopes_implicit_h5( N, h, u, edge_slopes, h_neglect, answers_201 ! ----------------------------------------------------------------------------- ! Local variables - integer :: i, j, k ! loop indexes - real :: h0, h1, h2, h3 ! cell widths + real :: h0, h1, h2, h3 ! cell widths [H] + real :: hMin ! The minimum thickness used in these calculations [H] real :: g, g_2, g_3 ! the following are real :: g_4, g_5, g_6 ! auxiliary variables real :: d2, d3, d4, d5, d6 ! to set up the systems @@ -311,20 +311,18 @@ subroutine edge_slopes_implicit_h5( N, h, u, edge_slopes, h_neglect, answers_201 tri_u, & ! trid. system (upper diagonal) tri_b, & ! trid. system (unknowns vector) tri_x ! trid. system (rhs) - real :: hNeglect ! A negligible thickness in the same units as h. - logical :: use_2018_answers ! If true use older, less acccurate expressions. + real :: h_Min_Frac = 1.0e-4 + real :: hNeglect ! A negligible thickness in the same units as h. + integer :: i, j, k ! loop indexes hNeglect = hNeglect_dflt ; if (present(h_neglect)) hNeglect = h_neglect - use_2018_answers = .true. ; if (present(answers_2018)) use_2018_answers = answers_2018 ! Loop on cells (except the first and last ones) do k = 2,N-2 - - ! Cell widths - h0 = h(k-1) - h1 = h(k+0) - h2 = h(k+1) - h3 = h(k+2) + ! Store temporary cell widths, avoiding singularities from zero thicknesses or extreme changes. + hMin = max(hNeglect, h_Min_Frac*((h(k-1) + h(k)) + (h(k+1) + h(k+2)))) + h0 = max(h(k-1), hMin) ; h1 = max(h(k), hMin) + h2 = max(h(k+1), hMin) ; h3 = max(h(k+2), hMin) ! Auxiliary calculations h1_2 = h1 * h1 @@ -346,11 +344,11 @@ subroutine edge_slopes_implicit_h5( N, h, u, edge_slopes, h_neglect, answers_201 g_5 = g_4 * g g_6 = g_3 * g_3 - d2 = ( h1_2 - g_2 ) / ( h0 + hNeglect ) - d3 = ( h1_3 - g_3 ) / ( h0 + hNeglect ) - d4 = ( h1_4 - g_4 ) / ( h0 + hNeglect ) - d5 = ( h1_5 - g_5 ) / ( h0 + hNeglect ) - d6 = ( h1_6 - g_6 ) / ( h0 + hNeglect ) + d2 = ( h1_2 - g_2 ) / ( h0 ) + d3 = ( h1_3 - g_3 ) / ( h0 ) + d4 = ( h1_4 - g_4 ) / ( h0 ) + d5 = ( h1_5 - g_5 ) / ( h0 ) + d6 = ( h1_6 - g_6 ) / ( h0 ) g = h2 + h3 g_2 = g * g @@ -359,11 +357,11 @@ subroutine edge_slopes_implicit_h5( N, h, u, edge_slopes, h_neglect, answers_201 g_5 = g_4 * g g_6 = g_3 * g_3 - n2 = ( g_2 - h2_2 ) / ( h3 + hNeglect ) - n3 = ( g_3 - h2_3 ) / ( h3 + hNeglect ) - n4 = ( g_4 - h2_4 ) / ( h3 + hNeglect ) - n5 = ( g_5 - h2_5 ) / ( h3 + hNeglect ) - n6 = ( g_6 - h2_6 ) / ( h3 + hNeglect ) + n2 = ( g_2 - h2_2 ) / ( h3 ) + n3 = ( g_3 - h2_3 ) / ( h3 ) + n4 = ( g_4 - h2_4 ) / ( h3 ) + n5 = ( g_5 - h2_5 ) / ( h3 ) + n6 = ( g_6 - h2_6 ) / ( h3 ) ! Compute matrix entries Asys(1,1) = 0.0 @@ -410,7 +408,7 @@ subroutine edge_slopes_implicit_h5( N, h, u, edge_slopes, h_neglect, answers_201 Bsys(:) = (/ 0.0, -1.0, 0.0, 0.0, 0.0, 0.0 /) - call solve_linear_system( Asys, Bsys, Csys, 6, use_2018_answers ) + call solve_linear_system( Asys, Bsys, Csys, 6, .false. ) alpha = Csys(1) beta = Csys(2) @@ -428,11 +426,10 @@ subroutine edge_slopes_implicit_h5( N, h, u, edge_slopes, h_neglect, answers_201 ! Use a right-biased stencil for the second row - ! Cell widths - h0 = h(1) - h1 = h(2) - h2 = h(3) - h3 = h(4) + ! Store temporary cell widths, avoiding singularities from zero thic2nesses or extreme changes. + hMin = max(hNeglect, h_Min_Frac*((h(1) + h(2)) + (h(3) + h(4)))) + h0 = max(h(1), hMin) ; h1 = max(h(2), hMin) + h2 = max(h(3), hMin) ; h3 = max(h(4), hMin) ! Auxiliary calculations h1_2 = h1 * h1 @@ -459,11 +456,11 @@ subroutine edge_slopes_implicit_h5( N, h, u, edge_slopes, h_neglect, answers_201 h0ph1_3 = h0ph1_2 * h0ph1 h0ph1_4 = h0ph1_2 * h0ph1_2 - d2 = ( h1_2 - g_2 ) / ( h0 + hNeglect ) - d3 = ( h1_3 - g_3 ) / ( h0 + hNeglect ) - d4 = ( h1_4 - g_4 ) / ( h0 + hNeglect ) - d5 = ( h1_5 - g_5 ) / ( h0 + hNeglect ) - d6 = ( h1_6 - g_6 ) / ( h0 + hNeglect ) + d2 = ( h1_2 - g_2 ) / ( h0 ) + d3 = ( h1_3 - g_3 ) / ( h0 ) + d4 = ( h1_4 - g_4 ) / ( h0 ) + d5 = ( h1_5 - g_5 ) / ( h0 ) + d6 = ( h1_6 - g_6 ) / ( h0 ) g = h2 + h3 g_2 = g * g @@ -472,11 +469,11 @@ subroutine edge_slopes_implicit_h5( N, h, u, edge_slopes, h_neglect, answers_201 g_5 = g_4 * g g_6 = g_3 * g_3 - n2 = ( g_2 - h2_2 ) / ( h3 + hNeglect ) - n3 = ( g_3 - h2_3 ) / ( h3 + hNeglect ) - n4 = ( g_4 - h2_4 ) / ( h3 + hNeglect ) - n5 = ( g_5 - h2_5 ) / ( h3 + hNeglect ) - n6 = ( g_6 - h2_6 ) / ( h3 + hNeglect ) + n2 = ( g_2 - h2_2 ) / ( h3 ) + n3 = ( g_3 - h2_3 ) / ( h3 ) + n4 = ( g_4 - h2_4 ) / ( h3 ) + n5 = ( g_5 - h2_5 ) / ( h3 ) + n6 = ( g_6 - h2_6 ) / ( h3 ) ! Compute matrix entries Asys(1,1) = 0.0 @@ -523,7 +520,7 @@ subroutine edge_slopes_implicit_h5( N, h, u, edge_slopes, h_neglect, answers_201 Bsys(:) = (/ 0.0, -1.0, -h1, h1_2/2.0, -h1_3/6.0, h1_4/24.0 /) - call solve_linear_system( Asys, Bsys, Csys, 6, use_2018_answers ) + call solve_linear_system( Asys, Bsys, Csys, 6, .false. ) alpha = Csys(1) beta = Csys(2) @@ -541,25 +538,18 @@ subroutine edge_slopes_implicit_h5( N, h, u, edge_slopes, h_neglect, answers_201 x(1) = 0.0 do i = 1,6 dx = h(i) + xavg = x(i) + 0.5 * dx + Asys(i,1) = 1.0 + Asys(i,2) = xavg + Asys(i,3) = (xavg**2 + C1_12*dx**2) + Asys(i,4) = xavg * (xavg**2 + 0.25*dx**2) + Asys(i,5) = (xavg**4 + 0.5*xavg**2*dx**2 + 0.0125*dx**4) + Asys(i,6) = xavg * (xavg**4 + C5_6*xavg**2*dx**2 + 0.0625*dx**4) + Bsys(i) = u(i) x(i+1) = x(i) + dx - if (use_2018_answers) then - do j = 1,6 ; Asys(i,j) = ( (x(i+1)**j) - (x(i)**j) ) / j ; enddo - Bsys(i) = u(i) * dx - else ! Use expressions with less sensitivity to roundoff - xavg = 0.5 * (x(i+1) + x(i)) - Asys(i,1) = 1.0 - Asys(i,2) = xavg - Asys(i,3) = (xavg**2 + C1_12*dx**2) - Asys(i,4) = xavg * (xavg**2 + 0.25*dx**2) - Asys(i,5) = (xavg**4 + 0.5*xavg**2*dx**2 + 0.0125*dx**4) - Asys(i,6) = xavg * (xavg**4 + C5_6*xavg**2*dx**2 + 0.0625*dx**4) - Bsys(i) = u(i) - endif - - enddo - call solve_linear_system( Asys, Bsys, Csys, 6, use_2018_answers ) + call solve_linear_system( Asys, Bsys, Csys, 6, .false. ) Dsys(1) = Csys(2) Dsys(2) = 2.0 * Csys(3) @@ -573,12 +563,10 @@ subroutine edge_slopes_implicit_h5( N, h, u, edge_slopes, h_neglect, answers_201 tri_b(1) = evaluation_polynomial( Dsys, 5, x(1) ) ! first edge value ! Use a left-biased stencil for the second to last row - - ! Cell widths - h0 = h(N-3) - h1 = h(N-2) - h2 = h(N-1) - h3 = h(N) + ! Store temporary cell widths, avoiding singularities from zero thicknesses or extreme changes. + hMin = max(hNeglect, h_Min_Frac*((h(N-3) + h(N-2)) + (h(N-1) + h(N)))) + h0 = max(h(N-3), hMin) ; h1 = max(h(N-2), hMin) + h2 = max(h(N-1), hMin) ; h3 = max(h(N), hMin) ! Auxiliary calculations h1_2 = h1 * h1 @@ -605,11 +593,11 @@ subroutine edge_slopes_implicit_h5( N, h, u, edge_slopes, h_neglect, answers_201 h2ph3_3 = h2ph3_2 * h2ph3 h2ph3_4 = h2ph3_2 * h2ph3_2 - d2 = ( h1_2 - g_2 ) / ( h0 + hNeglect ) - d3 = ( h1_3 - g_3 ) / ( h0 + hNeglect ) - d4 = ( h1_4 - g_4 ) / ( h0 + hNeglect ) - d5 = ( h1_5 - g_5 ) / ( h0 + hNeglect ) - d6 = ( h1_6 - g_6 ) / ( h0 + hNeglect ) + d2 = ( h1_2 - g_2 ) / ( h0 ) + d3 = ( h1_3 - g_3 ) / ( h0 ) + d4 = ( h1_4 - g_4 ) / ( h0 ) + d5 = ( h1_5 - g_5 ) / ( h0 ) + d6 = ( h1_6 - g_6 ) / ( h0 ) g = h2 + h3 g_2 = g * g @@ -618,11 +606,11 @@ subroutine edge_slopes_implicit_h5( N, h, u, edge_slopes, h_neglect, answers_201 g_5 = g_4 * g g_6 = g_3 * g_3 - n2 = ( g_2 - h2_2 ) / ( h3 + hNeglect ) - n3 = ( g_3 - h2_3 ) / ( h3 + hNeglect ) - n4 = ( g_4 - h2_4 ) / ( h3 + hNeglect ) - n5 = ( g_5 - h2_5 ) / ( h3 + hNeglect ) - n6 = ( g_6 - h2_6 ) / ( h3 + hNeglect ) + n2 = ( g_2 - h2_2 ) / ( h3 ) + n3 = ( g_3 - h2_3 ) / ( h3 ) + n4 = ( g_4 - h2_4 ) / ( h3 ) + n5 = ( g_5 - h2_5 ) / ( h3 ) + n6 = ( g_6 - h2_6 ) / ( h3 ) ! Compute matrix entries Asys(1,1) = 0.0 @@ -669,7 +657,7 @@ subroutine edge_slopes_implicit_h5( N, h, u, edge_slopes, h_neglect, answers_201 Bsys(:) = (/ 0.0, -1.0, h2, h2_2/2.0, h2_3/6.0, h2_4/24.0 /) - call solve_linear_system( Asys, Bsys, Csys, 6, use_2018_answers ) + call solve_linear_system( Asys, Bsys, Csys, 6, .false. ) alpha = Csys(1) beta = Csys(2) @@ -687,23 +675,18 @@ subroutine edge_slopes_implicit_h5( N, h, u, edge_slopes, h_neglect, answers_201 x(1) = 0.0 do i = 1,6 dx = h(N-6+i) + xavg = x(i) + 0.5*dx + Asys(i,1) = 1.0 + Asys(i,2) = xavg + Asys(i,3) = (xavg**2 + C1_12*dx**2) + Asys(i,4) = xavg * (xavg**2 + 0.25*dx**2) + Asys(i,5) = (xavg**4 + 0.5*xavg**2*dx**2 + 0.0125*dx**4) + Asys(i,6) = xavg * (xavg**4 + C5_6*xavg**2*dx**2 + 0.0625*dx**4) + Bsys(i) = u(N-6+i) x(i+1) = x(i) + dx - if (use_2018_answers) then - do j = 1,6 ; Asys(i,j) = ( (x(i+1)**j) - (x(i)**j) ) / j ; enddo - Bsys(i) = u(N-6+i) * dx - else ! Use expressions with less sensitivity to roundoff - xavg = 0.5 * (x(i+1) + x(i)) - Asys(i,1) = 1.0 - Asys(i,2) = xavg - Asys(i,3) = (xavg**2 + C1_12*dx**2) - Asys(i,4) = xavg * (xavg**2 + 0.25*dx**2) - Asys(i,5) = (xavg**4 + 0.5*xavg**2*dx**2 + 0.0125*dx**4) - Asys(i,6) = xavg * (xavg**4 + C5_6*xavg**2*dx**2 + 0.0625*dx**4) - Bsys(i) = u(N-6+i) - endif enddo - call solve_linear_system( Asys, Bsys, Csys, 6, use_2018_answers ) + call solve_linear_system( Asys, Bsys, Csys, 6, .false. ) Dsys(1) = Csys(2) Dsys(2) = 2.0 * Csys(3) diff --git a/src/ALE/regrid_edge_values.F90 b/src/ALE/regrid_edge_values.F90 index c2e9f5f04d..6912ae5bb0 100644 --- a/src/ALE/regrid_edge_values.F90 +++ b/src/ALE/regrid_edge_values.F90 @@ -703,8 +703,9 @@ end subroutine end_value_h4 !! i-1/2 i+1/2 i+3/2 !! !! In this routine, the coefficients \f$\alpha\f$, \f$\beta\f$, a, b, c and d are -!! computed, the tridiagonal system is built, boundary conditions are -!! prescribed and the system is solved to yield edge-value estimates. +!! computed, the tridiagonal system is built, boundary conditions are prescribed and +!! the system is solved to yield edge-value estimates. This scheme is described in detail +!! by White and Adcroft, 2009, J. Comp. Phys, https://doi.org/10.1016/j.jcp.2008.04.026 !! !! Note that the centered stencil only applies to edges 3 to N-1 (edges are !! numbered 1 to n+1), which yields N-3 equations for N+1 unknowns. Two other @@ -727,11 +728,11 @@ subroutine edge_values_implicit_h6( N, h, u, edge_val, h_neglect, answers_2018 ) logical, optional, intent(in) :: answers_2018 !< If true use older, less acccurate expressions. ! Local variables - integer :: i, j, k ! loop indexes - real :: h0, h1, h2, h3 ! cell widths [H] - real :: hMin ! The minimum thickness used in these calculations [H] + real :: h0, h1, h2, h3 ! cell widths [H] + real :: hMin ! The minimum thickness used in these calculations [H] real :: h01, h01_2, h01_3, h01_4, h01_5, h01_6 ! Summed thicknesses to various powers [H^n ~> m^n or kg^n m-2n] real :: h23, h23_2, h23_3, h23_4, h23_5, h23_6 ! Summed thicknesses to various powers [H^n ~> m^n or kg^n m-2n] + real :: hNeglect ! A negligible thickness [H]. real :: d2, d3, d4, d5, d6 ! to set up the systems real :: n2, n3, n4, n5, n6 ! used to compute the real :: h1_2, h2_2 ! the coefficients of the @@ -757,30 +758,16 @@ subroutine edge_values_implicit_h6( N, h, u, edge_val, h_neglect, answers_2018 ) tri_u, & ! trid. system (upper diagonal) tri_b, & ! trid. system (unknowns vector) tri_x ! trid. system (rhs) - real :: hNeglect ! A negligible thickness [H]. - logical :: use_2018_answers ! If true use older, less acccurate expressions. + integer :: i, j, k ! loop indexes - use_2018_answers = .true. ; if (present(answers_2018)) use_2018_answers = answers_2018 hNeglect = hNeglect_edge_dflt ; if (present(h_neglect)) hNeglect = h_neglect - ! Loop on cells (except last one) ! Loop on interior cells do k = 2,N-2 - - ! Cell widths - h0 = h(k-1) - h1 = h(k+0) - h2 = h(k+1) - h3 = h(k+2) - - ! Avoid singularities when h0=0 or h3=0 - if (h0*h3==0.) then - hMin = hMinFrac * max( hNeglect, h0+h1+h2+h3 ) - h0 = max( hMin, h0 ) - h1 = max( hMin, h1 ) - h2 = max( hMin, h2 ) - h3 = max( hMin, h3 ) - endif + ! Store temporary cell widths, avoiding singularities from zero thicknesses or extreme changes. + hMin = max(hNeglect, hMinFrac*((h(k-1) + h(k)) + (h(k+1) + h(k+2)))) + h0 = max(h(k-1), hMin) ; h1 = max(h(k), hMin) + h2 = max(h(k+1), hMin) ; h3 = max(h(k+2), hMin) ! Auxiliary calculations h1_2 = h1 * h1 @@ -821,7 +808,7 @@ subroutine edge_values_implicit_h6( N, h, u, edge_val, h_neglect, answers_2018 ) n5 = ( h23_5 - h2_5 ) / h3 ! = 5.0*h2_4 + h3*(10.0*h2_3 + h3*(10.0*h2_2 + h3*(5.0*h2 + h3))) n6 = ( h23_6 - h2_6 ) / h3 ! = 6.0*h2_5 + h3*(15.0*h2_4 + h3*(20.0*h2_3 + h3*(15.0*h2_2 + h3*(6.0*h2 + h3)))) - ! Compute matrix entries + ! Compute matrix entries as described in Eq. (48) of White and Adcroft (2009) Asys(1,1) = 1.0 Asys(1,2) = 1.0 Asys(1,3) = -1.0 @@ -866,7 +853,7 @@ subroutine edge_values_implicit_h6( N, h, u, edge_val, h_neglect, answers_2018 ) Bsys(:) = (/ -1.0, 0.0, 0.0, 0.0, 0.0, 0.0 /) - call solve_linear_system( Asys, Bsys, Csys, 6, use_2018_answers ) + call solve_linear_system( Asys, Bsys, Csys, 6, .false. ) alpha = Csys(1) beta = Csys(2) @@ -882,22 +869,12 @@ subroutine edge_values_implicit_h6( N, h, u, edge_val, h_neglect, answers_2018 ) enddo ! end loop on cells - ! Use a right-biased stencil for the second row - - ! Cell widths - h0 = h(1) - h1 = h(2) - h2 = h(3) - h3 = h(4) - - ! Avoid singularities when h0=0 or h3=0 - if (h0*h3==0.) then - hMin = hMinFrac * max( hNeglect, h0+h1+h2+h3 ) - h0 = max( hMin, h0 ) - h1 = max( hMin, h1 ) - h2 = max( hMin, h2 ) - h3 = max( hMin, h3 ) - endif + ! Use a right-biased stencil for the second row, as described in Eq. (49) of White and Adcroft (2009). + + ! Store temporary cell widths, avoiding singularities from zero thicknesses or extreme changes. + hMin = max(hNeglect, hMinFrac*((h(1) + h(2)) + (h(3) + h(4)))) + h0 = max(h(1), hMin) ; h1 = max(h(2), hMin) + h2 = max(h(3), hMin) ; h3 = max(h(4), hMin) ! Auxiliary calculations h1_2 = h1 * h1 @@ -985,7 +962,7 @@ subroutine edge_values_implicit_h6( N, h, u, edge_val, h_neglect, answers_2018 ) Bsys(:) = (/ -1.0, h1, -0.5*h1_2, h1_3/6.0, -h1_4/24.0, h1_5/120.0 /) - call solve_linear_system( Asys, Bsys, Csys, 6, use_2018_answers ) + call solve_linear_system( Asys, Bsys, Csys, 6, .false. ) alpha = Csys(1) beta = Csys(2) @@ -996,29 +973,22 @@ subroutine edge_values_implicit_h6( N, h, u, edge_val, h_neglect, answers_2018 ) tri_b(2) = Csys(3) * u(1) + Csys(4) * u(2) + Csys(5) * u(3) + Csys(6) * u(4) ! Boundary conditions: left boundary -! h_min = hMinFrac * ((h(1) + h(2)) + (h(5) + h(6)) + (h(3) + h(4))) - hMin = max( hNeglect, hMinFrac*sum(h(1:6)) ) + hMin = max( hNeglect, hMinFrac*((h(1)+h(2)) + (h(5)+h(6)) + (h(3)+h(4))) ) x(1) = 0.0 do i = 1,6 dx = max( hMin, h(i) ) + xavg = x(i) + 0.5*dx + Asys(i,1) = 1.0 + Asys(i,2) = xavg + Asys(i,3) = (xavg**2 + C1_12*dx**2) + Asys(i,4) = xavg * (xavg**2 + 0.25*dx**2) + Asys(i,5) = (xavg**4 + 0.5*xavg**2*dx**2 + 0.0125*dx**4) + Asys(i,6) = xavg * (xavg**4 + C5_6*xavg**2*dx**2 + 0.0625*dx**4) + Bsys(i) = u(i) x(i+1) = x(i) + dx - if (use_2018_answers) then - do j = 1,6 ; Asys(i,j) = ( (x(i+1)**j) - (x(i)**j) ) / j ; enddo - Bsys(i) = u(i) * dx - else ! Use expressions with less sensitivity to roundoff - xavg = 0.5 * (x(i+1) + x(i)) - Asys(i,1) = 1.0 - Asys(i,2) = xavg - Asys(i,3) = (xavg**2 + C1_12*dx**2) - Asys(i,4) = xavg * (xavg**2 + 0.25*dx**2) - Asys(i,5) = (xavg**4 + 0.5*xavg**2*dx**2 + 0.0125*dx**4) - Asys(i,6) = xavg * (xavg**4 + C5_6*xavg**2*dx**2 + 0.0625*dx**4) - Bsys(i) = u(i) - endif - enddo - call solve_linear_system( Asys, Bsys, Csys, 6, use_2018_answers ) + call solve_linear_system( Asys, Bsys, Csys, 6, .false. ) tri_l(1) = 0.0 tri_d(1) = 1.0 @@ -1027,20 +997,10 @@ subroutine edge_values_implicit_h6( N, h, u, edge_val, h_neglect, answers_2018 ) ! Use a left-biased stencil for the second to last row - ! Cell widths - h0 = h(N-3) - h1 = h(N-2) - h2 = h(N-1) - h3 = h(N) - - ! Avoid singularities when h0=0 or h3=0 - if (h0*h3==0.) then - hMin = hMinFrac * max( hNeglect, h0+h1+h2+h3 ) - h0 = max( hMin, h0 ) - h1 = max( hMin, h1 ) - h2 = max( hMin, h2 ) - h3 = max( hMin, h3 ) - endif + ! Store temporary cell widths, avoiding singularities from zero thicknesses or extreme changes. + hMin = max(hNeglect, hMinFrac*((h(N-3) + h(N-2)) + (h(N-1) + h(N)))) + h0 = max(h(N-3), hMin) ; h1 = max(h(N-2), hMin) + h2 = max(h(N-1), hMin) ; h3 = max(h(N), hMin) ! Auxiliary calculations h1_2 = h1 * h1 @@ -1132,7 +1092,7 @@ subroutine edge_values_implicit_h6( N, h, u, edge_val, h_neglect, answers_2018 ) Bsys(:) = (/ -1.0, -h2, -0.5*h2_2, -h2_3/6.0, -h2_4/24.0, -h2_5/120.0 /) - call solve_linear_system( Asys, Bsys, Csys, 6, use_2018_answers ) + call solve_linear_system( Asys, Bsys, Csys, 6, .false. ) alpha = Csys(1) beta = Csys(2) @@ -1147,29 +1107,22 @@ subroutine edge_values_implicit_h6( N, h, u, edge_val, h_neglect, answers_2018 ) tri_b(N) = a * u(N-3) + b * u(N-2) + c * u(N-1) + d * u(N) ! Boundary conditions: right boundary -! h_sum = (h(N-3) + h(N-2)) + ((h(N-1) + h(N)) + (h(N-5) + h(N-4))) - hMin = max( hNeglect, hMinFrac*sum(h(N-5:N)) ) + hMin = max( hNeglect, hMinFrac*(h(N-3) + h(N-2)) + ((h(N-1) + h(N)) + (h(N-5) + h(N-4))) ) x(1) = 0.0 do i = 1,6 dx = max( hMin, h(N-6+i) ) + xavg = x(i) + 0.5 * dx + Asys(i,1) = 1.0 + Asys(i,2) = xavg + Asys(i,3) = (xavg**2 + C1_12*dx**2) + Asys(i,4) = xavg * (xavg**2 + 0.25*dx**2) + Asys(i,5) = (xavg**4 + 0.5*xavg**2*dx**2 + 0.0125*dx**4) + Asys(i,6) = xavg * (xavg**4 + C5_6*xavg**2*dx**2 + 0.0625*dx**4) + Bsys(i) = u(N-6+i) x(i+1) = x(i) + dx - if (use_2018_answers) then - do j = 1,6 ; Asys(i,j) = ( (x(i+1)**j) - (x(i)**j) ) / j ; enddo - Bsys(i) = u(N-6+i) * dx - else ! Use expressions with less sensitivity to roundoff - xavg = 0.5 * (x(i+1) + x(i)) - Asys(i,1) = 1.0 - Asys(i,2) = xavg - Asys(i,3) = (xavg**2 + C1_12*dx**2) - Asys(i,4) = xavg * (xavg**2 + 0.25*dx**2) - Asys(i,5) = (xavg**4 + 0.5*xavg**2*dx**2 + 0.0125*dx**4) - Asys(i,6) = xavg * (xavg**4 + C5_6*xavg**2*dx**2 + 0.0625*dx**4) - Bsys(i) = u(N-6+i) - endif - enddo - call solve_linear_system( Asys, Bsys, Csys, 6, use_2018_answers ) + call solve_linear_system( Asys, Bsys, Csys, 6, .false. ) tri_l(N+1) = 0.0 tri_d(N+1) = 1.0 From b6281836b032cf077418a583627c5ca65eec4efa Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Mon, 13 Jan 2020 19:32:32 -0500 Subject: [PATCH 024/316] (*)Improved algorithms in edge_slopes_implicit_h5 Replaced the n2 and d2 variables in edge_values_implicit_h6 and edge_slopes_implicit_h5 with mathematically equivalent forms that avoid any subtractions and hence are much less prone to roundoff. Also multiplied matricies by constants in edge_values_implicit_h6 and edge_slopes_implicit_h5 to avoid division and make these expressions more consistent with what is documented in White and Adcroft (2009). Also renamed some variables for greater clarity. Expressions are mathematically identical but do change at roundoff. --- src/ALE/regrid_edge_slopes.F90 | 353 +++++++++++---------------------- src/ALE/regrid_edge_values.F90 | 337 ++++++++++--------------------- 2 files changed, 219 insertions(+), 471 deletions(-) diff --git a/src/ALE/regrid_edge_slopes.F90 b/src/ALE/regrid_edge_slopes.F90 index 5bfb5b287a..6021d19fc5 100644 --- a/src/ALE/regrid_edge_slopes.F90 +++ b/src/ALE/regrid_edge_slopes.F90 @@ -284,21 +284,14 @@ subroutine edge_slopes_implicit_h5( N, h, u, edge_slopes, h_neglect, answers_201 ! Local variables real :: h0, h1, h2, h3 ! cell widths [H] real :: hMin ! The minimum thickness used in these calculations [H] - real :: g, g_2, g_3 ! the following are - real :: g_4, g_5, g_6 ! auxiliary variables - real :: d2, d3, d4, d5, d6 ! to set up the systems - real :: n2, n3, n4, n5, n6 ! used to compute the + real :: h01, h01_2 ! Summed thicknesses to various powers [H^n ~> m^n or kg^n m-2n] + real :: h23, h23_2 ! Summed thicknesses to various powers [H^n ~> m^n or kg^n m-2n] + real :: hNeglect ! A negligible thickness [H]. real :: h1_2, h2_2 ! the coefficients of the real :: h1_3, h2_3 ! tridiagonal system real :: h1_4, h2_4 ! ... real :: h1_5, h2_5 ! ... - real :: h1_6, h2_6 ! ... - real :: h0ph1, h0ph1_2 ! ... - real :: h0ph1_3, h0ph1_4 ! ... - real :: h2ph3, h2ph3_2 ! ... - real :: h2ph3_3, h2ph3_4 ! ... real :: alpha, beta ! stencil coefficients - real :: a, b, c, d ! " real, dimension(7) :: x ! Coordinate system with 0 at edges [same units as h] real, parameter :: C1_12 = 1.0 / 12.0 real, parameter :: C5_6 = 5.0 / 6.0 @@ -312,7 +305,6 @@ subroutine edge_slopes_implicit_h5( N, h, u, edge_slopes, h_neglect, answers_201 tri_b, & ! trid. system (unknowns vector) tri_x ! trid. system (rhs) real :: h_Min_Frac = 1.0e-4 - real :: hNeglect ! A negligible thickness in the same units as h. integer :: i, j, k ! loop indexes hNeglect = hNeglect_dflt ; if (present(h_neglect)) hNeglect = h_neglect @@ -325,45 +317,10 @@ subroutine edge_slopes_implicit_h5( N, h, u, edge_slopes, h_neglect, answers_201 h2 = max(h(k+1), hMin) ; h3 = max(h(k+2), hMin) ! Auxiliary calculations - h1_2 = h1 * h1 - h1_3 = h1_2 * h1 - h1_4 = h1_2 * h1_2 - h1_5 = h1_3 * h1_2 - h1_6 = h1_3 * h1_3 - - h2_2 = h2 * h2 - h2_3 = h2_2 * h2 - h2_4 = h2_2 * h2_2 - h2_5 = h2_3 * h2_2 - h2_6 = h2_3 * h2_3 - - g = h0 + h1 - g_2 = g * g - g_3 = g * g_2 - g_4 = g_2 * g_2 - g_5 = g_4 * g - g_6 = g_3 * g_3 - - d2 = ( h1_2 - g_2 ) / ( h0 ) - d3 = ( h1_3 - g_3 ) / ( h0 ) - d4 = ( h1_4 - g_4 ) / ( h0 ) - d5 = ( h1_5 - g_5 ) / ( h0 ) - d6 = ( h1_6 - g_6 ) / ( h0 ) - - g = h2 + h3 - g_2 = g * g - g_3 = g * g_2 - g_4 = g_2 * g_2 - g_5 = g_4 * g - g_6 = g_3 * g_3 - - n2 = ( g_2 - h2_2 ) / ( h3 ) - n3 = ( g_3 - h2_3 ) / ( h3 ) - n4 = ( g_4 - h2_4 ) / ( h3 ) - n5 = ( g_5 - h2_5 ) / ( h3 ) - n6 = ( g_6 - h2_6 ) / ( h3 ) - - ! Compute matrix entries + h1_2 = h1 * h1 ; h1_3 = h1_2 * h1 ; h1_4 = h1_2 * h1_2 ; h1_5 = h1_3 * h1_2 + h2_2 = h2 * h2 ; h2_3 = h2_2 * h2 ; h2_4 = h2_2 * h2_2 ; h2_5 = h2_3 * h2_2 + + ! Compute matrix entries as described in Eq. (52) of White and Adcroft (2009) Asys(1,1) = 0.0 Asys(1,2) = 0.0 Asys(1,3) = 1.0 @@ -371,109 +328,66 @@ subroutine edge_slopes_implicit_h5( N, h, u, edge_slopes, h_neglect, answers_201 Asys(1,5) = 1.0 Asys(1,6) = 1.0 - Asys(2,1) = 1.0 - Asys(2,2) = 1.0 - Asys(2,3) = -0.5 * d2 - Asys(2,4) = 0.5 * h1 - Asys(2,5) = -0.5 * h2 - Asys(2,6) = -0.5 * n2 - - Asys(3,1) = h1 - Asys(3,2) = - h2 - Asys(3,3) = - d3 / 6.0 - Asys(3,4) = h1_2 / 6.0 - Asys(3,5) = h2_2 / 6.0 - Asys(3,6) = n3 / 6.0 - - Asys(4,1) = - h1_2 / 2.0 - Asys(4,2) = - h2_2 / 2.0 - Asys(4,3) = d4 / 24.0 - Asys(4,4) = - h1_3 / 24.0 - Asys(4,5) = h2_3 / 24.0 - Asys(4,6) = n4 / 24.0 - - Asys(5,1) = h1_3 / 6.0 - Asys(5,2) = - h2_3 / 6.0 - Asys(5,3) = - d5 / 120.0 - Asys(5,4) = h1_4 / 120.0 - Asys(5,5) = h2_4 / 120.0 - Asys(5,6) = n5 / 120.0 - - Asys(6,1) = - h1_4 / 24.0 - Asys(6,2) = - h2_4 / 24.0 - Asys(6,3) = d6 / 720.0 - Asys(6,4) = - h1_5 / 720.0 - Asys(6,5) = h2_5 / 720.0 - Asys(6,6) = n6 / 720.0 - - Bsys(:) = (/ 0.0, -1.0, 0.0, 0.0, 0.0, 0.0 /) + Asys(2,1) = 2.0 + Asys(2,2) = 2.0 + Asys(2,3) = (2.0*h1 + h0) + Asys(2,4) = h1 + Asys(2,5) = -h2 + Asys(2,6) = -(2.0*h2 + h3) + + Asys(3,1) = 6.0*h1 + Asys(3,2) = -6.0* h2 + Asys(3,3) = (3.0*h1_2 + h0*(3.0*h1 + h0)) ! = ((h0+h1)**3 - h1**3) / h0 + Asys(3,4) = h1_2 + Asys(3,5) = h2_2 + Asys(3,6) = (3.0*h2_2 + h3*(3.0*h2 + h3)) ! = ((h2+h3)**3 - h2**3) / h3 + + Asys(4,1) = -12.0* h1_2 + Asys(4,2) = -12.0* h2_2 + Asys(4,3) = -(4.0*h1_3 + h0*(6.0*h1_2 + h0*(4.0*h1 + h0))) ! = -((h0+h1)**4 - h1**4) / h0 + Asys(4,4) = - h1_3 + Asys(4,5) = h2_3 + Asys(4,6) = (4.0*h2_3 + h3*(6.0*h2_2 + h3*(4.0*h2 + h3))) ! = ((h2+h3)**4 - h2**4)/ h3 + + Asys(5,1) = 20.0*h1_3 + Asys(5,2) = -20.0* h2_3 + Asys(5,3) = (5.0*h1_4 + h0*(10.0*h1_3 + h0*(10.0*h1_2 + h0*(5.0*h1 + h0)))) + Asys(5,4) = h1_4 + Asys(5,5) = h2_4 + Asys(5,6) = (5.0*h2_4 + h3*(10.0*h2_3 + h3*(10.0*h2_2 + h3*(5.0*h2 + h3)))) + + Asys(6,1) = -30.0*h1_4 + Asys(6,2) = -30.0*h2_4 + Asys(6,3) = -(6.0*h1_5 + h0*(15.0*h1_4 + h0*(20.0*h1_3 + h0*(15.0*h1_2 + h0*(6.0*h1 + h0))))) + Asys(6,4) = -h1_5 + Asys(6,5) = h2_5 + Asys(6,6) = (6.0*h2_5 + h3*(15.0*h2_4 + h3*(20.0*h2_3 + h3*(15.0*h2_2 + h3*(6.0*h2 + h3))))) + + Bsys(:) = (/ 0.0, -2.0, 0.0, 0.0, 0.0, 0.0 /) call solve_linear_system( Asys, Bsys, Csys, 6, .false. ) alpha = Csys(1) beta = Csys(2) - a = Csys(3) - b = Csys(4) - c = Csys(5) - d = Csys(6) tri_l(k+1) = alpha tri_d(k+1) = 1.0 tri_u(k+1) = beta - tri_b(k+1) = a * u(k-1) + b * u(k) + c * u(k+1) + d * u(k+2) + tri_b(k+1) = Csys(3) * u(k-1) + Csys(4) * u(k) + Csys(5) * u(k+1) + Csys(6) * u(k+2) enddo ! end loop on cells - ! Use a right-biased stencil for the second row + ! Use a right-biased stencil for the second row, as described in Eq. (53) of White and Adcroft (2009). - ! Store temporary cell widths, avoiding singularities from zero thic2nesses or extreme changes. + ! Store temporary cell widths, avoiding singularities from zero thicknesses or extreme changes. hMin = max(hNeglect, h_Min_Frac*((h(1) + h(2)) + (h(3) + h(4)))) h0 = max(h(1), hMin) ; h1 = max(h(2), hMin) h2 = max(h(3), hMin) ; h3 = max(h(4), hMin) ! Auxiliary calculations - h1_2 = h1 * h1 - h1_3 = h1_2 * h1 - h1_4 = h1_2 * h1_2 - h1_5 = h1_3 * h1_2 - h1_6 = h1_3 * h1_3 - - h2_2 = h2 * h2 - h2_3 = h2_2 * h2 - h2_4 = h2_2 * h2_2 - h2_5 = h2_3 * h2_2 - h2_6 = h2_3 * h2_3 - - g = h0 + h1 - g_2 = g * g - g_3 = g * g_2 - g_4 = g_2 * g_2 - g_5 = g_4 * g - g_6 = g_3 * g_3 - - h0ph1 = h0 + h1 - h0ph1_2 = h0ph1 * h0ph1 - h0ph1_3 = h0ph1_2 * h0ph1 - h0ph1_4 = h0ph1_2 * h0ph1_2 - - d2 = ( h1_2 - g_2 ) / ( h0 ) - d3 = ( h1_3 - g_3 ) / ( h0 ) - d4 = ( h1_4 - g_4 ) / ( h0 ) - d5 = ( h1_5 - g_5 ) / ( h0 ) - d6 = ( h1_6 - g_6 ) / ( h0 ) - - g = h2 + h3 - g_2 = g * g - g_3 = g * g_2 - g_4 = g_2 * g_2 - g_5 = g_4 * g - g_6 = g_3 * g_3 - - n2 = ( g_2 - h2_2 ) / ( h3 ) - n3 = ( g_3 - h2_3 ) / ( h3 ) - n4 = ( g_4 - h2_4 ) / ( h3 ) - n5 = ( g_5 - h2_5 ) / ( h3 ) - n6 = ( g_6 - h2_6 ) / ( h3 ) + h1_2 = h1 * h1 ; h1_3 = h1_2 * h1 ; h1_4 = h1_2 * h1_2 ; h1_5 = h1_3 * h1_2 + h2_2 = h2 * h2 ; h2_3 = h2_2 * h2 ; h2_4 = h2_2 * h2_2 ; h2_5 = h2_3 * h2_2 + h01 = h0 + h1 ; h01_2 = h01 * h01 ! Compute matrix entries Asys(1,1) = 0.0 @@ -483,56 +397,52 @@ subroutine edge_slopes_implicit_h5( N, h, u, edge_slopes, h_neglect, answers_201 Asys(1,5) = 1.0 Asys(1,6) = 1.0 - Asys(2,1) = 1.0 - Asys(2,2) = 1.0 - Asys(2,3) = -0.5 * d2 - Asys(2,4) = 0.5 * h1 - Asys(2,5) = -0.5 * h2 - Asys(2,6) = -0.5 * n2 + Asys(2,1) = 2.0 + Asys(2,2) = 2.0 + Asys(2,3) = (2.0*h1 + h0) + Asys(2,4) = h1 + Asys(2,5) = -h2 + Asys(2,6) = -(2.0*h2 + h3) - Asys(3,1) = h0ph1 + Asys(3,1) = 6.0*h01 Asys(3,2) = 0.0 - Asys(3,3) = - d3 / 6.0 - Asys(3,4) = h1_2 / 6.0 - Asys(3,5) = h2_2 / 6.0 - Asys(3,6) = n3 / 6.0 + Asys(3,3) = (3.0*h1_2 + h0*(3.0*h1 + h0)) + Asys(3,4) = h1_2 + Asys(3,5) = h2_2 + Asys(3,6) = 3.0*h2_2 + h3*(3.0*h2 + h3) - Asys(4,1) = - h0ph1_2 / 2.0 + Asys(4,1) = -12.0*h01_2 Asys(4,2) = 0.0 - Asys(4,3) = d4 / 24.0 - Asys(4,4) = - h1_3 / 24.0 - Asys(4,5) = h2_3 / 24.0 - Asys(4,6) = n4 / 24.0 + Asys(4,3) = -(4.0*h1_3 + h0*(6.0*h1_2 + h0*(4.0*h1 + h0))) + Asys(4,4) = -h1_3 + Asys(4,5) = h2_3 + Asys(4,6) = 4.0*h2_3 + h3*(6.0*h2_2 + h3*(4.0*h2 + h3)) - Asys(5,1) = h0ph1_3 / 6.0 + Asys(5,1) = 20.0*(h01*h01_2) Asys(5,2) = 0.0 - Asys(5,3) = - d5 / 120.0 - Asys(5,4) = h1_4 / 120.0 - Asys(5,5) = h2_4 / 120.0 - Asys(5,6) = n5 / 120.0 + Asys(5,3) = (5.0*h1_4 + h0*(10.0*h1_3 + h0*(10.0*h1_2 + h0*(5.0*h1 + h0)))) + Asys(5,4) = h1_4 + Asys(5,5) = h2_4 + Asys(5,6) = 5.0*h2_4 + h3*(10.0*h2_3 + h3*(10.0*h2_2 + h3*(5.0*h2 + h3))) - Asys(6,1) = - h0ph1_4 / 24.0 + Asys(6,1) = -30.0*(h01_2*h01_2) Asys(6,2) = 0.0 - Asys(6,3) = d6 / 720.0 - Asys(6,4) = - h1_5 / 720.0 - Asys(6,5) = h2_5 / 720.0 - Asys(6,6) = n6 / 720.0 + Asys(6,3) = -(6.0*h1_5 + h0*(15.0*h1_4 + h0*(20.0*h1_3 + h0*(15.0*h1_2 + h0*(6.0*h1 + h0))))) + Asys(6,4) = -h1_5 + Asys(6,5) = h2_5 + Asys(6,6) = 6.0*h2_5 + h3*(15.0*h2_4 + h3*(20.0*h2_3 + h3*(15.0*h2_2 + h3*(6.0*h2 + h3)))) - Bsys(:) = (/ 0.0, -1.0, -h1, h1_2/2.0, -h1_3/6.0, h1_4/24.0 /) + Bsys(:) = (/ 0.0, -2.0, -6.0*h1, 12.0*h1_2, -20.0*h1_3, 30.0*h1_4 /) call solve_linear_system( Asys, Bsys, Csys, 6, .false. ) alpha = Csys(1) beta = Csys(2) - a = Csys(3) - b = Csys(4) - c = Csys(5) - d = Csys(6) tri_l(2) = alpha tri_d(2) = 1.0 tri_u(2) = beta - tri_b(2) = a * u(1) + b * u(2) + c * u(3) + d * u(4) + tri_b(2) = Csys(3) * u(1) + Csys(4) * u(2) + Csys(5) * u(3) + Csys(6) * u(4) ! Boundary conditions: left boundary x(1) = 0.0 @@ -562,55 +472,18 @@ subroutine edge_slopes_implicit_h5( N, h, u, edge_slopes, h_neglect, answers_201 tri_u(1) = 0.0 tri_b(1) = evaluation_polynomial( Dsys, 5, x(1) ) ! first edge value - ! Use a left-biased stencil for the second to last row + ! Use a left-biased stencil for the second to last row, as described in Eq. (54) of White and Adcroft (2009). + ! Store temporary cell widths, avoiding singularities from zero thicknesses or extreme changes. hMin = max(hNeglect, h_Min_Frac*((h(N-3) + h(N-2)) + (h(N-1) + h(N)))) h0 = max(h(N-3), hMin) ; h1 = max(h(N-2), hMin) h2 = max(h(N-1), hMin) ; h3 = max(h(N), hMin) ! Auxiliary calculations - h1_2 = h1 * h1 - h1_3 = h1_2 * h1 - h1_4 = h1_2 * h1_2 - h1_5 = h1_3 * h1_2 - h1_6 = h1_3 * h1_3 - - h2_2 = h2 * h2 - h2_3 = h2_2 * h2 - h2_4 = h2_2 * h2_2 - h2_5 = h2_3 * h2_2 - h2_6 = h2_3 * h2_3 - - g = h0 + h1 - g_2 = g * g - g_3 = g * g_2 - g_4 = g_2 * g_2 - g_5 = g_4 * g - g_6 = g_3 * g_3 - - h2ph3 = h2 + h3 - h2ph3_2 = h2ph3 * h2ph3 - h2ph3_3 = h2ph3_2 * h2ph3 - h2ph3_4 = h2ph3_2 * h2ph3_2 - - d2 = ( h1_2 - g_2 ) / ( h0 ) - d3 = ( h1_3 - g_3 ) / ( h0 ) - d4 = ( h1_4 - g_4 ) / ( h0 ) - d5 = ( h1_5 - g_5 ) / ( h0 ) - d6 = ( h1_6 - g_6 ) / ( h0 ) - - g = h2 + h3 - g_2 = g * g - g_3 = g * g_2 - g_4 = g_2 * g_2 - g_5 = g_4 * g - g_6 = g_3 * g_3 - - n2 = ( g_2 - h2_2 ) / ( h3 ) - n3 = ( g_3 - h2_3 ) / ( h3 ) - n4 = ( g_4 - h2_4 ) / ( h3 ) - n5 = ( g_5 - h2_5 ) / ( h3 ) - n6 = ( g_6 - h2_6 ) / ( h3 ) + h1_2 = h1 * h1 ; h1_3 = h1_2 * h1 ; h1_4 = h1_2 * h1_2 ; h1_5 = h1_3 * h1_2 + h2_2 = h2 * h2 ; h2_3 = h2_2 * h2 ; h2_4 = h2_2 * h2_2 ; h2_5 = h2_3 * h2_2 + + h23 = h2 + h3 ; h23_2 = h23 * h23 ! Compute matrix entries Asys(1,1) = 0.0 @@ -620,56 +493,52 @@ subroutine edge_slopes_implicit_h5( N, h, u, edge_slopes, h_neglect, answers_201 Asys(1,5) = 1.0 Asys(1,6) = 1.0 - Asys(2,1) = 1.0 - Asys(2,2) = 1.0 - Asys(2,3) = -0.5 * d2 - Asys(2,4) = 0.5 * h1 - Asys(2,5) = -0.5 * h2 - Asys(2,6) = -0.5 * n2 + Asys(2,1) = 2.0 + Asys(2,2) = 2.0 + Asys(2,3) = (2.0*h1 + h0) + Asys(2,4) = h1 + Asys(2,5) = -h2 + Asys(2,6) = -(2.0*h2 + h3) Asys(3,1) = 0.0 - Asys(3,2) = - h2ph3 - Asys(3,3) = - d3 / 6.0 - Asys(3,4) = h1_2 / 6.0 - Asys(3,5) = h2_2 / 6.0 - Asys(3,6) = n3 / 6.0 + Asys(3,2) = -6.0*h23 + Asys(3,3) = (3.0*h1_2 + h0*(3.0*h1 + h0)) + Asys(3,4) = h1_2 + Asys(3,5) = h2_2 + Asys(3,6) = 3.0*h2_2 + h3*(3.0*h2 + h3) Asys(4,1) = 0.0 - Asys(4,2) = - h2ph3_2 / 2.0 - Asys(4,3) = d4 / 24.0 - Asys(4,4) = - h1_3 / 24.0 - Asys(4,5) = h2_3 / 24.0 - Asys(4,6) = n4 / 24.0 + Asys(4,2) = -12.0*h23_2 + Asys(4,3) = -(4.0*h1_3 + h0*(6.0*h1_2 + h0*(4.0*h1 + h0))) + Asys(4,4) = -h1_3 + Asys(4,5) = h2_3 + Asys(4,6) = 4.0*h2_3 + h3*(6.0*h2_2 + h3*(4.0*h2 + h3)) Asys(5,1) = 0.0 - Asys(5,2) = - h2ph3_3 / 6.0 - Asys(5,3) = - d5 / 120.0 - Asys(5,4) = h1_4 / 120.0 - Asys(5,5) = h2_4 / 120.0 - Asys(5,6) = n5 / 120.0 + Asys(5,2) = -20.0*(h23*h23_2) + Asys(5,3) = (5.0*h1_4 + h0*(10.0*h1_3 + h0*(10.0*h1_2 + h0*(5.0*h1 + h0)))) + Asys(5,4) = h1_4 + Asys(5,5) = h2_4 + Asys(5,6) = 5.0*h2_4 + h3*(10.0*h2_3 + h3*(10.0*h2_2 + h3*(5.0*h2 + h3))) Asys(6,1) = 0.0 - Asys(6,2) = - h2ph3_4 / 24.0 - Asys(6,3) = d6 / 720.0 - Asys(6,4) = - h1_5 / 720.0 - Asys(6,5) = h2_5 / 720.0 - Asys(6,6) = n6 / 720.0 + Asys(6,2) = -30.0*(h23_2*h23_2) + Asys(6,3) = -(6.0*h1_5 + h0*(15.0*h1_4 + h0*(20.0*h1_3 + h0*(15.0*h1_2 + h0*(6.0*h1 + h0))))) + Asys(6,4) = -h1_5 + Asys(6,5) = h2_5 + Asys(6,6) = 6.0*h2_5 + h3*(15.0*h2_4 + h3*(20.0*h2_3 + h3*(15.0*h2_2 + h3*(6.0*h2 + h3)))) - Bsys(:) = (/ 0.0, -1.0, h2, h2_2/2.0, h2_3/6.0, h2_4/24.0 /) + Bsys(:) = (/ 0.0, -2.0, 6.0*h2, 12.0*h2_2, 20.0*h2_3, 30.0*h2_4 /) call solve_linear_system( Asys, Bsys, Csys, 6, .false. ) alpha = Csys(1) beta = Csys(2) - a = Csys(3) - b = Csys(4) - c = Csys(5) - d = Csys(6) tri_l(N) = alpha tri_d(N) = 1.0 tri_u(N) = beta - tri_b(N) = a * u(N-3) + b * u(N-2) + c * u(N-1) + d * u(N) + tri_b(N) = Csys(3) * u(N-3) + Csys(4) * u(N-2) + Csys(5) * u(N-1) + Csys(6) * u(N) ! Boundary conditions: right boundary x(1) = 0.0 diff --git a/src/ALE/regrid_edge_values.F90 b/src/ALE/regrid_edge_values.F90 index 6912ae5bb0..76dab697c8 100644 --- a/src/ALE/regrid_edge_values.F90 +++ b/src/ALE/regrid_edge_values.F90 @@ -730,8 +730,8 @@ subroutine edge_values_implicit_h6( N, h, u, edge_val, h_neglect, answers_2018 ) ! Local variables real :: h0, h1, h2, h3 ! cell widths [H] real :: hMin ! The minimum thickness used in these calculations [H] - real :: h01, h01_2, h01_3, h01_4, h01_5, h01_6 ! Summed thicknesses to various powers [H^n ~> m^n or kg^n m-2n] - real :: h23, h23_2, h23_3, h23_4, h23_5, h23_6 ! Summed thicknesses to various powers [H^n ~> m^n or kg^n m-2n] + real :: h01, h01_2, h01_3 ! Summed thicknesses to various powers [H^n ~> m^n or kg^n m-2n] + real :: h23, h23_2, h23_3 ! Summed thicknesses to various powers [H^n ~> m^n or kg^n m-2n] real :: hNeglect ! A negligible thickness [H]. real :: d2, d3, d4, d5, d6 ! to set up the systems real :: n2, n3, n4, n5, n6 ! used to compute the @@ -739,12 +739,6 @@ subroutine edge_values_implicit_h6( N, h, u, edge_val, h_neglect, answers_2018 ) real :: h1_3, h2_3 ! tridiagonal system real :: h1_4, h2_4 ! ... real :: h1_5, h2_5 ! ... - real :: h1_6, h2_6 ! ... - real :: h0ph1, h0ph1_2 ! ... - real :: h0ph1_3, h0ph1_4 ! ... - real :: h2ph3, h2ph3_2 ! ... - real :: h2ph3_3, h2ph3_4 ! ... - real :: h0ph1_5, h2ph3_5 ! ... real :: alpha, beta ! stencil coefficients real :: a, b, c, d ! " real, dimension(7) :: x ! Coordinate system with 0 at edges [same units as h] @@ -770,43 +764,8 @@ subroutine edge_values_implicit_h6( N, h, u, edge_val, h_neglect, answers_2018 ) h2 = max(h(k+1), hMin) ; h3 = max(h(k+2), hMin) ! Auxiliary calculations - h1_2 = h1 * h1 - h1_3 = h1_2 * h1 - h1_4 = h1_2 * h1_2 - h1_5 = h1_3 * h1_2 - h1_6 = h1_3 * h1_3 - - h2_2 = h2 * h2 - h2_3 = h2_2 * h2 - h2_4 = h2_2 * h2_2 - h2_5 = h2_3 * h2_2 - h2_6 = h2_3 * h2_3 - - h01 = h0 + h1 - h01_2 = h01 * h01 - h01_3 = h01 * h01_2 - h01_4 = h01_2 * h01_2 - h01_5 = h01_4 * h01 - h01_6 = h01_3 * h01_3 - - d2 = ( h01_2 - h1_2 ) / h0 ! = (2.0*h1 + h0) - d3 = ( h01_3 - h1_3 ) / h0 ! = (3.0*h1_2 + h0*(3.0*h1 + h0)) - d4 = ( h01_4 - h1_4 ) / h0 ! = (4.0*h1_3 + h0*(6.0*h1_2 + h0*(4.0*h1 + h0))) - d5 = ( h01_5 - h1_5 ) / h0 ! = (5.0*h1_4 + h0*(10.0*h1_3 + h0*(10.0*h1_2 + h0*(5.0*h1 + h0)))) - d6 = ( h01_6 - h1_6 ) / h0 ! = (6.0*h1_5 + h0*(15.0*h1_4 + h0*(20.0*h1_3 + h0*(15.0*h1_2 + h0*(6.0*h1 + h0))))) - - h23 = h2 + h3 - h23_2 = h23 * h23 - h23_3 = h23 * h23_2 - h23_4 = h23_2 * h23_2 - h23_5 = h23_4 * h23 - h23_6 = h23_3 * h23_3 - - n2 = ( h23_2 - h2_2 ) / h3 ! = 2.0*h2 + h3 - n3 = ( h23_3 - h2_3 ) / h3 ! = 3.0*h2_2 + h3*(3.0*h2 + h3) - n4 = ( h23_4 - h2_4 ) / h3 ! = 4.0*h2_3 + h3*(6.0*h2_2 + h3*(4.0*h2 + h3)) - n5 = ( h23_5 - h2_5 ) / h3 ! = 5.0*h2_4 + h3*(10.0*h2_3 + h3*(10.0*h2_2 + h3*(5.0*h2 + h3))) - n6 = ( h23_6 - h2_6 ) / h3 ! = 6.0*h2_5 + h3*(15.0*h2_4 + h3*(20.0*h2_3 + h3*(15.0*h2_2 + h3*(6.0*h2 + h3)))) + h1_2 = h1 * h1 ; h1_3 = h1_2 * h1 ; h1_4 = h1_2 * h1_2 ; h1_5 = h1_3 * h1_2 + h2_2 = h2 * h2 ; h2_3 = h2_2 * h2 ; h2_4 = h2_2 * h2_2 ; h2_5 = h2_3 * h2_2 ! Compute matrix entries as described in Eq. (48) of White and Adcroft (2009) Asys(1,1) = 1.0 @@ -816,40 +775,40 @@ subroutine edge_values_implicit_h6( N, h, u, edge_val, h_neglect, answers_2018 ) Asys(1,5) = -1.0 Asys(1,6) = -1.0 - Asys(2,1) = - h1 - Asys(2,2) = h2 - Asys(2,3) = 0.5 * d2 - Asys(2,4) = 0.5 * h1 - Asys(2,5) = -0.5 * h2 - Asys(2,6) = -0.5 * n2 - - Asys(3,1) = 0.5 * h1_2 - Asys(3,2) = 0.5 * h2_2 - Asys(3,3) = -d3 / 6.0 - Asys(3,4) = - h1_2 / 6.0 - Asys(3,5) = - h2_2 / 6.0 - Asys(3,6) = - n3 / 6.0 - - Asys(4,1) = - h1_3 / 6.0 - Asys(4,2) = h2_3 / 6.0 - Asys(4,3) = d4 / 24.0 - Asys(4,4) = h1_3 / 24.0 - Asys(4,5) = - h2_3 / 24.0 - Asys(4,6) = - n4 / 24.0 - - Asys(5,1) = h1_4 / 24.0 - Asys(5,2) = h2_4 / 24.0 - Asys(5,3) = -d5 / 120.0 - Asys(5,4) = - h1_4 / 120.0 - Asys(5,5) = - h2_4 / 120.0 - Asys(5,6) = - n5 / 120.0 - - Asys(6,1) = - h1_5 / 120.0 - Asys(6,2) = h2_5 / 120.0 - Asys(6,3) = d6 / 720.0 - Asys(6,4) = h1_5 / 720.0 - Asys(6,5) = - h2_5 / 720.0 - Asys(6,6) = - n6 / 720.0 + Asys(2,1) = -2.0*h1 + Asys(2,2) = 2.0*h2 + Asys(2,3) = (2.0*h1 + h0) + Asys(2,4) = h1 + Asys(2,5) = -h2 + Asys(2,6) = -(2.0*h2 + h3) + + Asys(3,1) = 3.0*h1_2 + Asys(3,2) = 3.0*h2_2 + Asys(3,3) = -(3.0*h1_2 + h0*(3.0*h1 + h0)) ! = -((h0+h1)**3 - h1**3) / h0 + Asys(3,4) = - h1_2 + Asys(3,5) = - h2_2 + Asys(3,6) = -(3.0*h2_2 + h3*(3.0*h2 + h3)) ! = -((h2+h3)**3 - h2**3) / h3 + + Asys(4,1) = -4.0*h1_3 + Asys(4,2) = 4.0*h2_3 + Asys(4,3) = (4.0*h1_3 + h0*(6.0*h1_2 + h0*(4.0*h1 + h0))) ! = ((h0+h1)**4 - h1**4) / h0 + Asys(4,4) = h1_3 + Asys(4,5) = - h2_3 + Asys(4,6) = -(4.0*h2_3 + h3*(6.0*h2_2 + h3*(4.0*h2 + h3))) ! = -((h2+h3)**4 - h2**4)/ h3 + + Asys(5,1) = 5.0*h1_4 + Asys(5,2) = 5.0*h2_4 + Asys(5,3) = -(5.0*h1_4 + h0*(10.0*h1_3 + h0*(10.0*h1_2 + h0*(5.0*h1 + h0)))) + Asys(5,4) = - h1_4 + Asys(5,5) = - h2_4 + Asys(5,6) = -(5.0*h2_4 + h3*(10.0*h2_3 + h3*(10.0*h2_2 + h3*(5.0*h2 + h3)))) + + Asys(6,1) = -6.0*h1_5 + Asys(6,2) = 6.0*h2_5 + Asys(6,3) = (6.0*h1_5 + h0*(15.0*h1_4 + h0*(20.0*h1_3 + h0*(15.0*h1_2 + h0*(6.0*h1 + h0))))) + Asys(6,4) = h1_5 + Asys(6,5) = - h2_5 + Asys(6,6) = -(6.0*h2_5 + h3*(15.0*h2_4 + h3*(20.0*h2_3 + h3*(15.0*h2_2 + h3*(6.0*h2 + h3))))) Bsys(:) = (/ -1.0, 0.0, 0.0, 0.0, 0.0, 0.0 /) @@ -857,15 +816,11 @@ subroutine edge_values_implicit_h6( N, h, u, edge_val, h_neglect, answers_2018 ) alpha = Csys(1) beta = Csys(2) - a = Csys(3) - b = Csys(4) - c = Csys(5) - d = Csys(6) tri_l(k+1) = alpha tri_d(k+1) = 1.0 tri_u(k+1) = beta - tri_b(k+1) = a * u(k-1) + b * u(k) + c * u(k+1) + d * u(k+2) + tri_b(k+1) = Csys(3) * u(k-1) + Csys(4) * u(k) + Csys(5) * u(k+1) + Csys(6) * u(k+2) enddo ! end loop on cells @@ -877,45 +832,9 @@ subroutine edge_values_implicit_h6( N, h, u, edge_val, h_neglect, answers_2018 ) h2 = max(h(3), hMin) ; h3 = max(h(4), hMin) ! Auxiliary calculations - h1_2 = h1 * h1 - h1_3 = h1_2 * h1 - h1_4 = h1_2 * h1_2 - h1_5 = h1_3 * h1_2 - h1_6 = h1_3 * h1_3 - - h2_2 = h2 * h2 - h2_3 = h2_2 * h2 - h2_4 = h2_2 * h2_2 - h2_5 = h2_3 * h2_2 - h2_6 = h2_3 * h2_3 - - h01 = h0 + h1 ; h01_2 = h01 * h01 ; h01_3 = h01 * h01_2 - h01_4 = h01_2 * h01_2 ; h01_5 = h01_4 * h01 ; h01_6 = h01_3 * h01_3 - - d2 = ( h01_2 - h1_2 ) / h0 ! = (2.0*h1 + h0) - d3 = ( h01_3 - h1_3 ) / h0 ! = (3.0*h1_2 + h0*(3.0*h1 + h0)) - d4 = ( h01_4 - h1_4 ) / h0 ! = (4.0*h1_3 + h0*(6.0*h1_2 + h0*(4.0*h1 + h0))) - d5 = ( h01_5 - h1_5 ) / h0 ! = (5.0*h1_4 + h0*(10.0*h1_3 + h0*(10.0*h1_2 + h0*(5.0*h1 + h0)))) - d6 = ( h01_6 - h1_6 ) / h0 ! = (6.0*h1_5 + h0*(15.0*h1_4 + h0*(20.0*h1_3 + h0*(15.0*h1_2 + h0*(6.0*h1 + h0))))) - - h23 = h2 + h3 - h23_2 = h23 * h23 - h23_3 = h23 * h23_2 - h23_4 = h23_2 * h23_2 - h23_5 = h23_4 * h23 - h23_6 = h23_3 * h23_3 - - n2 = ( h23_2 - h2_2 ) / h3 ! = 2.0*h2 + h3 - n3 = ( h23_3 - h2_3 ) / h3 ! = 3.0*h2_2 + h3*(3.0*h2 + h3) - n4 = ( h23_4 - h2_4 ) / h3 ! = 4.0*h2_3 + h3*(6.0*h2_2 + h3*(4.0*h2 + h3)) - n5 = ( h23_5 - h2_5 ) / h3 ! = 5.0*h2_4 + h3*(10.0*h2_3 + h3*(10.0*h2_2 + h3*(5.0*h2 + h3))) - n6 = ( h23_6 - h2_6 ) / h3 ! = 6.0*h2_5 + h3*(15.0*h2_4 + h3*(20.0*h2_3 + h3*(15.0*h2_2 + h3*(6.0*h2 + h3)))) - - h0ph1 = h0 + h1 - h0ph1_2 = h0ph1 * h0ph1 - h0ph1_3 = h0ph1_2 * h0ph1 - h0ph1_4 = h0ph1_2 * h0ph1_2 - h0ph1_5 = h0ph1_3 * h0ph1_2 + h1_2 = h1 * h1 ; h1_3 = h1_2 * h1 ; h1_4 = h1_2 * h1_2 ; h1_5 = h1_3 * h1_2 + h2_2 = h2 * h2 ; h2_3 = h2_2 * h2 ; h2_4 = h2_2 * h2_2 ; h2_5 = h2_3 * h2_2 + h01 = h0 + h1 ; h01_2 = h01 * h01 ; h01_3 = h01 * h01_2 ! Compute matrix entries Asys(1,1) = 1.0 @@ -925,42 +844,42 @@ subroutine edge_values_implicit_h6( N, h, u, edge_val, h_neglect, answers_2018 ) Asys(1,5) = -1.0 Asys(1,6) = -1.0 - Asys(2,1) = - h0ph1 + Asys(2,1) = -2.0* h01 Asys(2,2) = 0.0 - Asys(2,3) = 0.5 * d2 - Asys(2,4) = 0.5 * h1 - Asys(2,5) = -0.5 * h2 - Asys(2,6) = -0.5 * n2 + Asys(2,3) = (2.0*h1 + h0) + Asys(2,4) = h1 + Asys(2,5) = -h2 + Asys(2,6) = -(2.0*h2 + h3) - Asys(3,1) = 0.5 * h0ph1_2 + Asys(3,1) = 3.0 * h01_2 Asys(3,2) = 0.0 - Asys(3,3) = -d3 / 6.0 - Asys(3,4) = - h1_2 / 6.0 - Asys(3,5) = - h2_2 / 6.0 - Asys(3,6) = - n3 / 6.0 + Asys(3,3) = -(3.0*h1_2 + h0*(3.0*h1 + h0)) + Asys(3,4) = - h1_2 + Asys(3,5) = - h2_2 + Asys(3,6) = -(3.0*h2_2 + h3*(3.0*h2 + h3)) - Asys(4,1) = - h0ph1_3 / 6.0 + Asys(4,1) = -4.0*h01_3 Asys(4,2) = 0.0 - Asys(4,3) = d4 / 24.0 - Asys(4,4) = h1_3 / 24.0 - Asys(4,5) = - h2_3 / 24.0 - Asys(4,6) = - n4 / 24.0 + Asys(4,3) = (4.0*h1_3 + h0*(6.0*h1_2 + h0*(4.0*h1 + h0))) + Asys(4,4) = h1_3 + Asys(4,5) = - h2_3 + Asys(4,6) = -(4.0*h2_3 + h3*(6.0*h2_2 + h3*(4.0*h2 + h3))) - Asys(5,1) = h0ph1_4 / 24.0 + Asys(5,1) = 5.0*(h01_2*h01_2) Asys(5,2) = 0.0 - Asys(5,3) = -d5 / 120.0 - Asys(5,4) = - h1_4 / 120.0 - Asys(5,5) = - h2_4 / 120.0 - Asys(5,6) = - n5 / 120.0 + Asys(5,3) = -(5.0*h1_4 + h0*(10.0*h1_3 + h0*(10.0*h1_2 + h0*(5.0*h1 + h0)))) + Asys(5,4) = - h1_4 + Asys(5,5) = - h2_4 + Asys(5,6) = -(5.0*h2_4 + h3*(10.0*h2_3 + h3*(10.0*h2_2 + h3*(5.0*h2 + h3)))) - Asys(6,1) = - h0ph1_5 / 120.0 + Asys(6,1) = -6.0*(h01_3*h01_2) Asys(6,2) = 0.0 - Asys(6,3) = d6 / 720.0 - Asys(6,4) = h1_5 / 720.0 - Asys(6,5) = - h2_5 / 720.0 - Asys(6,6) = - n6 / 720.0 + Asys(6,3) = (6.0*h1_5 + h0*(15.0*h1_4 + h0*(20.0*h1_3 + h0*(15.0*h1_2 + h0*(6.0*h1 + h0))))) + Asys(6,4) = h1_5 + Asys(6,5) = - h2_5 + Asys(6,6) = -(6.0*h2_5 + h3*(15.0*h2_4 + h3*(20.0*h2_3 + h3*(15.0*h2_2 + h3*(6.0*h2 + h3))))) - Bsys(:) = (/ -1.0, h1, -0.5*h1_2, h1_3/6.0, -h1_4/24.0, h1_5/120.0 /) + Bsys(:) = (/ -1.0, 2.0*h1, -3.0*h1_2, 4.0*h1_3, -5.0*h1_4, 6.0*h1_5 /) call solve_linear_system( Asys, Bsys, Csys, 6, .false. ) @@ -995,7 +914,7 @@ subroutine edge_values_implicit_h6( N, h, u, edge_val, h_neglect, answers_2018 ) tri_u(1) = 0.0 tri_b(1) = evaluation_polynomial( Csys, 6, x(1) ) ! first edge value - ! Use a left-biased stencil for the second to last row + ! Use a left-biased stencil for the second to last row, as described in Eq. (50) of White and Adcroft (2009). ! Store temporary cell widths, avoiding singularities from zero thicknesses or extreme changes. hMin = max(hNeglect, hMinFrac*((h(N-3) + h(N-2)) + (h(N-1) + h(N)))) @@ -1003,49 +922,9 @@ subroutine edge_values_implicit_h6( N, h, u, edge_val, h_neglect, answers_2018 ) h2 = max(h(N-1), hMin) ; h3 = max(h(N), hMin) ! Auxiliary calculations - h1_2 = h1 * h1 - h1_3 = h1_2 * h1 - h1_4 = h1_2 * h1_2 - h1_5 = h1_3 * h1_2 - h1_6 = h1_3 * h1_3 - - h2_2 = h2 * h2 - h2_3 = h2_2 * h2 - h2_4 = h2_2 * h2_2 - h2_5 = h2_3 * h2_2 - h2_6 = h2_3 * h2_3 - - h01 = h0 + h1 - h01_2 = h01 * h01 - h01_3 = h01 * h01_2 - h01_4 = h01_2 * h01_2 - h01_5 = h01_4 * h01 - h01_6 = h01_3 * h01_3 - - d2 = ( h01_2 - h1_2 ) / h0 ! = (2.0*h1 + h0) - d3 = ( h01_3 - h1_3 ) / h0 ! = (3.0*h1_2 + h0*(3.0*h1 + h0)) - d4 = ( h01_4 - h1_4 ) / h0 ! = (4.0*h1_3 + h0*(6.0*h1_2 + h0*(4.0*h1 + h0))) - d5 = ( h01_5 - h1_5 ) / h0 ! = (5.0*h1_4 + h0*(10.0*h1_3 + h0*(10.0*h1_2 + h0*(5.0*h1 + h0)))) - d6 = ( h01_6 - h1_6 ) / h0 ! = (6.0*h1_5 + h0*(15.0*h1_4 + h0*(20.0*h1_3 + h0*(15.0*h1_2 + h0*(6.0*h1 + h0))))) - - h23 = h2 + h3 - h23_2 = h23 * h23 - h23_3 = h23 * h23_2 - h23_4 = h23_2 * h23_2 - h23_5 = h23_4 * h23 - h23_6 = h23_3 * h23_3 - - n2 = ( h23_2 - h2_2 ) / h3 ! = 2.0*h2 + h3 - n3 = ( h23_3 - h2_3 ) / h3 ! = 3.0*h2_2 + h3*(3.0*h2 + h3) - n4 = ( h23_4 - h2_4 ) / h3 ! = 4.0*h2_3 + h3*(6.0*h2_2 + h3*(4.0*h2 + h3)) - n5 = ( h23_5 - h2_5 ) / h3 ! = 5.0*h2_4 + h3*(10.0*h2_3 + h3*(10.0*h2_2 + h3*(5.0*h2 + h3))) - n6 = ( h23_6 - h2_6 ) / h3 ! = 6.0*h2_5 + h3*(15.0*h2_4 + h3*(20.0*h2_3 + h3*(15.0*h2_2 + h3*(6.0*h2 + h3)))) - - h2ph3 = h2 + h3 - h2ph3_2 = h2ph3 * h2ph3 - h2ph3_3 = h2ph3_2 * h2ph3 - h2ph3_4 = h2ph3_2 * h2ph3_2 - h2ph3_5 = h2ph3_3 * h2ph3_2 + h1_2 = h1 * h1 ; h1_3 = h1_2 * h1 ; h1_4 = h1_2 * h1_2 ; h1_5 = h1_3 * h1_2 + h2_2 = h2 * h2 ; h2_3 = h2_2 * h2 ; h2_4 = h2_2 * h2_2 ; h2_5 = h2_3 * h2_2 + h23 = h2 + h3 ; h23_2 = h23 * h23 ; h23_3 = h23 * h23_2 ! Compute matrix entries Asys(1,1) = 1.0 @@ -1055,42 +934,42 @@ subroutine edge_values_implicit_h6( N, h, u, edge_val, h_neglect, answers_2018 ) Asys(1,5) = -1.0 Asys(1,6) = -1.0 - Asys(2,1) = 0.0 - Asys(2,2) = h2ph3 - Asys(2,3) = 0.5 * d2 - Asys(2,4) = 0.5 * h1 - Asys(2,5) = -0.5 * h2 - Asys(2,6) = -0.5 * n2 - - Asys(3,1) = 0.0 - Asys(3,2) = 0.5 * h2ph3_2 - Asys(3,3) = -d3 / 6.0 - Asys(3,4) = - h1_2 / 6.0 - Asys(3,5) = - h2_2 / 6.0 - Asys(3,6) = - n3 / 6.0 - - Asys(4,1) = 0.0 - Asys(4,2) = h2ph3_3 / 6.0 - Asys(4,3) = d4 / 24.0 - Asys(4,4) = h1_3 / 24.0 - Asys(4,5) = - h2_3 / 24.0 - Asys(4,6) = - n4 / 24.0 - - Asys(5,1) = 0.0 - Asys(5,2) = h2ph3_4 / 24.0 - Asys(5,3) = - d5 / 120.0 - Asys(5,4) = - h1_4 / 120.0 - Asys(5,5) = - h2_4 / 120.0 - Asys(5,6) = - n5 / 120.0 - - Asys(6,1) = 0.0 - Asys(6,2) = h2ph3_5 / 120.0 - Asys(6,3) = d6 / 720.0 - Asys(6,4) = h1_5 / 720.0 - Asys(6,5) = - h2_5 / 720.0 - Asys(6,6) = - n6 / 720.0 - - Bsys(:) = (/ -1.0, -h2, -0.5*h2_2, -h2_3/6.0, -h2_4/24.0, -h2_5/120.0 /) + Asys(2,1) = 0.0 + Asys(2,2) = 2.0*h23 + Asys(2,3) = (2.0*h1 + h0) + Asys(2,4) = h1 + Asys(2,5) = -h2 + Asys(2,6) = -(2.0*h2 + h3) + + Asys(3,1) = 0.0 + Asys(3,2) = 3.0*h23_2 + Asys(3,3) = -(3.0*h1_2 + h0*(3.0*h1 + h0)) + Asys(3,4) = -h1_2 + Asys(3,5) = -h2_2 + Asys(3,6) = -(3.0*h2_2 + h3*(3.0*h2 + h3)) + + Asys(4,1) = 0.0 + Asys(4,2) = 4.0*h23_3 + Asys(4,3) = (4.0*h1_3 + h0*(6.0*h1_2 + h0*(4.0*h1 + h0))) + Asys(4,4) = h1_3 + Asys(4,5) = -h2_3 + Asys(4,6) = -(4.0*h2_3 + h3*(6.0*h2_2 + h3*(4.0*h2 + h3))) + + Asys(5,1) = 0.0 + Asys(5,2) = 5.0*(h23_2*h23_2) + Asys(5,3) = -(5.0*h1_4 + h0*(10.0*h1_3 + h0*(10.0*h1_2 + h0*(5.0*h1 + h0)))) + Asys(5,4) = -h1_4 + Asys(5,5) = -h2_4 + Asys(5,6) = -(5.0*h2_4 + h3*(10.0*h2_3 + h3*(10.0*h2_2 + h3*(5.0*h2 + h3)))) + + Asys(6,1) = 0.0 + Asys(6,2) = 6.0*(h23_3*h23_2) + Asys(6,3) = (6.0*h1_5 + h0*(15.0*h1_4 + h0*(20.0*h1_3 + h0*(15.0*h1_2 + h0*(6.0*h1 + h0))))) + Asys(6,4) = h1_5 + Asys(6,5) = -h2_5 + Asys(6,6) = -(6.0*h2_5 + h3*(15.0*h2_4 + h3*(20.0*h2_3 + h3*(15.0*h2_2 + h3*(6.0*h2 + h3))))) + + Bsys(:) = (/ -1.0, -2.0*h2, -3.0*h2_2, -4.0*h2_3, -5.0*h2_4, -6.0*h2_5 /) call solve_linear_system( Asys, Bsys, Csys, 6, .false. ) From 21c805bdd2d78662748be9165df617974903dec6 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Tue, 14 Jan 2020 06:52:48 -0500 Subject: [PATCH 025/316] Use linear_solver in edge_slopes_implicit_h5 Use linear_solver in place of solve_linear_system in edge_slopes_implicit_h5 and edge_values_implicit_h6, which increases efficiency because the arrays are accessed with a stride of 1 in memory. All answers are bitwise identical. --- src/ALE/regrid_edge_slopes.F90 | 223 +++++++++++++++++---------------- src/ALE/regrid_edge_values.F90 | 214 +++++++++++++++---------------- 2 files changed, 223 insertions(+), 214 deletions(-) diff --git a/src/ALE/regrid_edge_slopes.F90 b/src/ALE/regrid_edge_slopes.F90 index 6021d19fc5..bade56a46f 100644 --- a/src/ALE/regrid_edge_slopes.F90 +++ b/src/ALE/regrid_edge_slopes.F90 @@ -170,6 +170,7 @@ subroutine edge_slopes_implicit_h3( N, h, u, edge_slopes, h_neglect, answers_201 Asys(2,i) = xavg Asys(3,i) = (xavg**2 + C1_12*dx**2) Asys(4,i) = xavg * (xavg**2 + 0.25*dx**2) + ! Asys(1:4,i) = (/ 1.0, xavg, (xavg**2 + C1_12*dx**2), xavg * (xavg**2 + 0.25*dx**2) /) Bsys(i) = u(i) enddo @@ -210,6 +211,7 @@ subroutine edge_slopes_implicit_h3( N, h, u, edge_slopes, h_neglect, answers_201 Asys(2,i) = xavg Asys(3,i) = (xavg**2 + C1_12*dx**2) Asys(4,i) = xavg * (xavg**2 + 0.25*dx**2) + ! Asys(1:4,i) = (/ 1.0, xavg, (xavg**2 + C1_12*dx**2), xavg * (xavg**2 + 0.25*dx**2) /) Bsys(i) = u(N+1-i) enddo @@ -321,51 +323,54 @@ subroutine edge_slopes_implicit_h5( N, h, u, edge_slopes, h_neglect, answers_201 h2_2 = h2 * h2 ; h2_3 = h2_2 * h2 ; h2_4 = h2_2 * h2_2 ; h2_5 = h2_3 * h2_2 ! Compute matrix entries as described in Eq. (52) of White and Adcroft (2009) + ! Asys(1:6,n) = (/ -n*(n-1)*(-h1)**(n-2), -n*(n-1)*h1**(n-2), (-1)**(n-1) * ((h0+h1)**n - h0**n) / h0, & + ! (-h1)**(n-1), h2**(n-1), ((h2+h3)**n - h2**n) / h3 /) + Asys(1,1) = 0.0 - Asys(1,2) = 0.0 - Asys(1,3) = 1.0 - Asys(1,4) = 1.0 - Asys(1,5) = 1.0 - Asys(1,6) = 1.0 + Asys(2,1) = 0.0 + Asys(3,1) = 1.0 + Asys(4,1) = 1.0 + Asys(5,1) = 1.0 + Asys(6,1) = 1.0 - Asys(2,1) = 2.0 + Asys(1,2) = 2.0 Asys(2,2) = 2.0 - Asys(2,3) = (2.0*h1 + h0) - Asys(2,4) = h1 - Asys(2,5) = -h2 - Asys(2,6) = -(2.0*h2 + h3) + Asys(3,2) = (2.0*h1 + h0) + Asys(4,2) = h1 + Asys(5,2) = -h2 + Asys(6,2) = -(2.0*h2 + h3) - Asys(3,1) = 6.0*h1 - Asys(3,2) = -6.0* h2 + Asys(1,3) = 6.0*h1 + Asys(2,3) = -6.0* h2 Asys(3,3) = (3.0*h1_2 + h0*(3.0*h1 + h0)) ! = ((h0+h1)**3 - h1**3) / h0 - Asys(3,4) = h1_2 - Asys(3,5) = h2_2 - Asys(3,6) = (3.0*h2_2 + h3*(3.0*h2 + h3)) ! = ((h2+h3)**3 - h2**3) / h3 + Asys(4,3) = h1_2 + Asys(5,3) = h2_2 + Asys(6,3) = (3.0*h2_2 + h3*(3.0*h2 + h3)) ! = ((h2+h3)**3 - h2**3) / h3 - Asys(4,1) = -12.0* h1_2 - Asys(4,2) = -12.0* h2_2 - Asys(4,3) = -(4.0*h1_3 + h0*(6.0*h1_2 + h0*(4.0*h1 + h0))) ! = -((h0+h1)**4 - h1**4) / h0 + Asys(1,4) = -12.0* h1_2 + Asys(2,4) = -12.0* h2_2 + Asys(3,4) = -(4.0*h1_3 + h0*(6.0*h1_2 + h0*(4.0*h1 + h0))) ! = -((h0+h1)**4 - h1**4) / h0 Asys(4,4) = - h1_3 - Asys(4,5) = h2_3 - Asys(4,6) = (4.0*h2_3 + h3*(6.0*h2_2 + h3*(4.0*h2 + h3))) ! = ((h2+h3)**4 - h2**4)/ h3 + Asys(5,4) = h2_3 + Asys(6,4) = (4.0*h2_3 + h3*(6.0*h2_2 + h3*(4.0*h2 + h3))) ! = ((h2+h3)**4 - h2**4)/ h3 - Asys(5,1) = 20.0*h1_3 - Asys(5,2) = -20.0* h2_3 - Asys(5,3) = (5.0*h1_4 + h0*(10.0*h1_3 + h0*(10.0*h1_2 + h0*(5.0*h1 + h0)))) - Asys(5,4) = h1_4 + Asys(1,5) = 20.0*h1_3 + Asys(2,5) = -20.0* h2_3 + Asys(3,5) = (5.0*h1_4 + h0*(10.0*h1_3 + h0*(10.0*h1_2 + h0*(5.0*h1 + h0)))) + Asys(4,5) = h1_4 Asys(5,5) = h2_4 - Asys(5,6) = (5.0*h2_4 + h3*(10.0*h2_3 + h3*(10.0*h2_2 + h3*(5.0*h2 + h3)))) + Asys(6,5) = (5.0*h2_4 + h3*(10.0*h2_3 + h3*(10.0*h2_2 + h3*(5.0*h2 + h3)))) - Asys(6,1) = -30.0*h1_4 - Asys(6,2) = -30.0*h2_4 - Asys(6,3) = -(6.0*h1_5 + h0*(15.0*h1_4 + h0*(20.0*h1_3 + h0*(15.0*h1_2 + h0*(6.0*h1 + h0))))) - Asys(6,4) = -h1_5 - Asys(6,5) = h2_5 + Asys(1,6) = -30.0*h1_4 + Asys(2,6) = -30.0*h2_4 + Asys(3,6) = -(6.0*h1_5 + h0*(15.0*h1_4 + h0*(20.0*h1_3 + h0*(15.0*h1_2 + h0*(6.0*h1 + h0))))) + Asys(4,6) = -h1_5 + Asys(5,6) = h2_5 Asys(6,6) = (6.0*h2_5 + h3*(15.0*h2_4 + h3*(20.0*h2_3 + h3*(15.0*h2_2 + h3*(6.0*h2 + h3))))) Bsys(:) = (/ 0.0, -2.0, 0.0, 0.0, 0.0, 0.0 /) - call solve_linear_system( Asys, Bsys, Csys, 6, .false. ) + call linear_solver( 6, Asys, Bsys, Csys ) alpha = Csys(1) beta = Csys(2) @@ -391,50 +396,54 @@ subroutine edge_slopes_implicit_h5( N, h, u, edge_slopes, h_neglect, answers_201 ! Compute matrix entries Asys(1,1) = 0.0 - Asys(1,2) = 0.0 - Asys(1,3) = 1.0 - Asys(1,4) = 1.0 - Asys(1,5) = 1.0 - Asys(1,6) = 1.0 + Asys(2,1) = 0.0 + Asys(3,1) = 1.0 + Asys(4,1) = 1.0 + Asys(5,1) = 1.0 + Asys(6,1) = 1.0 - Asys(2,1) = 2.0 + Asys(1,2) = 2.0 Asys(2,2) = 2.0 - Asys(2,3) = (2.0*h1 + h0) - Asys(2,4) = h1 - Asys(2,5) = -h2 - Asys(2,6) = -(2.0*h2 + h3) + Asys(3,2) = (2.0*h1 + h0) + Asys(4,2) = h1 + Asys(5,2) = -h2 + Asys(6,2) = -(2.0*h2 + h3) - Asys(3,1) = 6.0*h01 - Asys(3,2) = 0.0 + Asys(1,3) = 6.0*h01 + Asys(2,3) = 0.0 Asys(3,3) = (3.0*h1_2 + h0*(3.0*h1 + h0)) - Asys(3,4) = h1_2 - Asys(3,5) = h2_2 - Asys(3,6) = 3.0*h2_2 + h3*(3.0*h2 + h3) + Asys(4,3) = h1_2 + Asys(5,3) = h2_2 + Asys(6,3) = 3.0*h2_2 + h3*(3.0*h2 + h3) + +! Asys(1:6,1) = (/ 0.0, 0.0, 1.0, 1.0, 1.0, 1.0 /) +! Asys(1:6,2) = (/ 2.0, 2.0, 2.0*h1 + h0, h1, -h2, -(2.0*h2 + h3) /) +! Asys(1:6,3) = (/ 6.0*h01, 0.0, 3.0*h1_2 + h0*(3.0*h1 + h0), h1_2, h2_2, 3.0*h2_2 + h3*(3.0*h2 + h3) /) - Asys(4,1) = -12.0*h01_2 - Asys(4,2) = 0.0 - Asys(4,3) = -(4.0*h1_3 + h0*(6.0*h1_2 + h0*(4.0*h1 + h0))) + Asys(1,4) = -12.0*h01_2 + Asys(2,4) = 0.0 + Asys(3,4) = -(4.0*h1_3 + h0*(6.0*h1_2 + h0*(4.0*h1 + h0))) Asys(4,4) = -h1_3 - Asys(4,5) = h2_3 - Asys(4,6) = 4.0*h2_3 + h3*(6.0*h2_2 + h3*(4.0*h2 + h3)) + Asys(5,4) = h2_3 + Asys(6,4) = 4.0*h2_3 + h3*(6.0*h2_2 + h3*(4.0*h2 + h3)) - Asys(5,1) = 20.0*(h01*h01_2) - Asys(5,2) = 0.0 - Asys(5,3) = (5.0*h1_4 + h0*(10.0*h1_3 + h0*(10.0*h1_2 + h0*(5.0*h1 + h0)))) - Asys(5,4) = h1_4 + Asys(1,5) = 20.0*(h01*h01_2) + Asys(2,5) = 0.0 + Asys(3,5) = (5.0*h1_4 + h0*(10.0*h1_3 + h0*(10.0*h1_2 + h0*(5.0*h1 + h0)))) + Asys(4,5) = h1_4 Asys(5,5) = h2_4 - Asys(5,6) = 5.0*h2_4 + h3*(10.0*h2_3 + h3*(10.0*h2_2 + h3*(5.0*h2 + h3))) + Asys(6,5) = 5.0*h2_4 + h3*(10.0*h2_3 + h3*(10.0*h2_2 + h3*(5.0*h2 + h3))) - Asys(6,1) = -30.0*(h01_2*h01_2) - Asys(6,2) = 0.0 - Asys(6,3) = -(6.0*h1_5 + h0*(15.0*h1_4 + h0*(20.0*h1_3 + h0*(15.0*h1_2 + h0*(6.0*h1 + h0))))) - Asys(6,4) = -h1_5 - Asys(6,5) = h2_5 + Asys(1,6) = -30.0*(h01_2*h01_2) + Asys(2,6) = 0.0 + Asys(3,6) = -(6.0*h1_5 + h0*(15.0*h1_4 + h0*(20.0*h1_3 + h0*(15.0*h1_2 + h0*(6.0*h1 + h0))))) + Asys(4,6) = -h1_5 + Asys(5,6) = h2_5 Asys(6,6) = 6.0*h2_5 + h3*(15.0*h2_4 + h3*(20.0*h2_3 + h3*(15.0*h2_2 + h3*(6.0*h2 + h3)))) Bsys(:) = (/ 0.0, -2.0, -6.0*h1, 12.0*h1_2, -20.0*h1_3, 30.0*h1_4 /) - call solve_linear_system( Asys, Bsys, Csys, 6, .false. ) + call linear_solver( 6, Asys, Bsys, Csys ) alpha = Csys(1) beta = Csys(2) @@ -449,17 +458,17 @@ subroutine edge_slopes_implicit_h5( N, h, u, edge_slopes, h_neglect, answers_201 do i = 1,6 dx = h(i) xavg = x(i) + 0.5 * dx - Asys(i,1) = 1.0 - Asys(i,2) = xavg - Asys(i,3) = (xavg**2 + C1_12*dx**2) - Asys(i,4) = xavg * (xavg**2 + 0.25*dx**2) - Asys(i,5) = (xavg**4 + 0.5*xavg**2*dx**2 + 0.0125*dx**4) - Asys(i,6) = xavg * (xavg**4 + C5_6*xavg**2*dx**2 + 0.0625*dx**4) + Asys(1,i) = 1.0 + Asys(2,i) = xavg + Asys(3,i) = (xavg**2 + C1_12*dx**2) + Asys(4,i) = xavg * (xavg**2 + 0.25*dx**2) + Asys(5,i) = (xavg**4 + 0.5*xavg**2*dx**2 + 0.0125*dx**4) + Asys(6,i) = xavg * (xavg**4 + C5_6*xavg**2*dx**2 + 0.0625*dx**4) Bsys(i) = u(i) x(i+1) = x(i) + dx enddo - call solve_linear_system( Asys, Bsys, Csys, 6, .false. ) + call linear_solver( 6, Asys, Bsys, Csys ) Dsys(1) = Csys(2) Dsys(2) = 2.0 * Csys(3) @@ -487,50 +496,50 @@ subroutine edge_slopes_implicit_h5( N, h, u, edge_slopes, h_neglect, answers_201 ! Compute matrix entries Asys(1,1) = 0.0 - Asys(1,2) = 0.0 - Asys(1,3) = 1.0 - Asys(1,4) = 1.0 - Asys(1,5) = 1.0 - Asys(1,6) = 1.0 + Asys(2,1) = 0.0 + Asys(3,1) = 1.0 + Asys(4,1) = 1.0 + Asys(5,1) = 1.0 + Asys(6,1) = 1.0 - Asys(2,1) = 2.0 + Asys(1,2) = 2.0 Asys(2,2) = 2.0 - Asys(2,3) = (2.0*h1 + h0) - Asys(2,4) = h1 - Asys(2,5) = -h2 - Asys(2,6) = -(2.0*h2 + h3) + Asys(3,2) = (2.0*h1 + h0) + Asys(4,2) = h1 + Asys(5,2) = -h2 + Asys(6,2) = -(2.0*h2 + h3) - Asys(3,1) = 0.0 - Asys(3,2) = -6.0*h23 + Asys(1,3) = 0.0 + Asys(2,3) = -6.0*h23 Asys(3,3) = (3.0*h1_2 + h0*(3.0*h1 + h0)) - Asys(3,4) = h1_2 - Asys(3,5) = h2_2 - Asys(3,6) = 3.0*h2_2 + h3*(3.0*h2 + h3) + Asys(4,3) = h1_2 + Asys(5,3) = h2_2 + Asys(6,3) = 3.0*h2_2 + h3*(3.0*h2 + h3) - Asys(4,1) = 0.0 - Asys(4,2) = -12.0*h23_2 - Asys(4,3) = -(4.0*h1_3 + h0*(6.0*h1_2 + h0*(4.0*h1 + h0))) + Asys(1,4) = 0.0 + Asys(2,4) = -12.0*h23_2 + Asys(3,4) = -(4.0*h1_3 + h0*(6.0*h1_2 + h0*(4.0*h1 + h0))) Asys(4,4) = -h1_3 - Asys(4,5) = h2_3 - Asys(4,6) = 4.0*h2_3 + h3*(6.0*h2_2 + h3*(4.0*h2 + h3)) + Asys(5,4) = h2_3 + Asys(6,4) = 4.0*h2_3 + h3*(6.0*h2_2 + h3*(4.0*h2 + h3)) - Asys(5,1) = 0.0 - Asys(5,2) = -20.0*(h23*h23_2) - Asys(5,3) = (5.0*h1_4 + h0*(10.0*h1_3 + h0*(10.0*h1_2 + h0*(5.0*h1 + h0)))) - Asys(5,4) = h1_4 + Asys(1,5) = 0.0 + Asys(2,5) = -20.0*(h23*h23_2) + Asys(3,5) = (5.0*h1_4 + h0*(10.0*h1_3 + h0*(10.0*h1_2 + h0*(5.0*h1 + h0)))) + Asys(4,5) = h1_4 Asys(5,5) = h2_4 - Asys(5,6) = 5.0*h2_4 + h3*(10.0*h2_3 + h3*(10.0*h2_2 + h3*(5.0*h2 + h3))) + Asys(6,5) = 5.0*h2_4 + h3*(10.0*h2_3 + h3*(10.0*h2_2 + h3*(5.0*h2 + h3))) - Asys(6,1) = 0.0 - Asys(6,2) = -30.0*(h23_2*h23_2) - Asys(6,3) = -(6.0*h1_5 + h0*(15.0*h1_4 + h0*(20.0*h1_3 + h0*(15.0*h1_2 + h0*(6.0*h1 + h0))))) - Asys(6,4) = -h1_5 - Asys(6,5) = h2_5 + Asys(1,6) = 0.0 + Asys(2,6) = -30.0*(h23_2*h23_2) + Asys(3,6) = -(6.0*h1_5 + h0*(15.0*h1_4 + h0*(20.0*h1_3 + h0*(15.0*h1_2 + h0*(6.0*h1 + h0))))) + Asys(4,6) = -h1_5 + Asys(5,6) = h2_5 Asys(6,6) = 6.0*h2_5 + h3*(15.0*h2_4 + h3*(20.0*h2_3 + h3*(15.0*h2_2 + h3*(6.0*h2 + h3)))) Bsys(:) = (/ 0.0, -2.0, 6.0*h2, 12.0*h2_2, 20.0*h2_3, 30.0*h2_4 /) - call solve_linear_system( Asys, Bsys, Csys, 6, .false. ) + call linear_solver( 6, Asys, Bsys, Csys ) alpha = Csys(1) beta = Csys(2) @@ -545,17 +554,17 @@ subroutine edge_slopes_implicit_h5( N, h, u, edge_slopes, h_neglect, answers_201 do i = 1,6 dx = h(N-6+i) xavg = x(i) + 0.5*dx - Asys(i,1) = 1.0 - Asys(i,2) = xavg - Asys(i,3) = (xavg**2 + C1_12*dx**2) - Asys(i,4) = xavg * (xavg**2 + 0.25*dx**2) - Asys(i,5) = (xavg**4 + 0.5*xavg**2*dx**2 + 0.0125*dx**4) - Asys(i,6) = xavg * (xavg**4 + C5_6*xavg**2*dx**2 + 0.0625*dx**4) + Asys(1,i) = 1.0 + Asys(2,i) = xavg + Asys(3,i) = (xavg**2 + C1_12*dx**2) + Asys(4,i) = xavg * (xavg**2 + 0.25*dx**2) + Asys(5,i) = (xavg**4 + 0.5*xavg**2*dx**2 + 0.0125*dx**4) + Asys(6,i) = xavg * (xavg**4 + C5_6*xavg**2*dx**2 + 0.0625*dx**4) Bsys(i) = u(N-6+i) x(i+1) = x(i) + dx enddo - call solve_linear_system( Asys, Bsys, Csys, 6, .false. ) + call linear_solver( 6, Asys, Bsys, Csys ) Dsys(1) = Csys(2) Dsys(2) = 2.0 * Csys(3) diff --git a/src/ALE/regrid_edge_values.F90 b/src/ALE/regrid_edge_values.F90 index 76dab697c8..80752f2d98 100644 --- a/src/ALE/regrid_edge_values.F90 +++ b/src/ALE/regrid_edge_values.F90 @@ -769,50 +769,50 @@ subroutine edge_values_implicit_h6( N, h, u, edge_val, h_neglect, answers_2018 ) ! Compute matrix entries as described in Eq. (48) of White and Adcroft (2009) Asys(1,1) = 1.0 - Asys(1,2) = 1.0 - Asys(1,3) = -1.0 - Asys(1,4) = -1.0 - Asys(1,5) = -1.0 - Asys(1,6) = -1.0 + Asys(2,1) = 1.0 + Asys(3,1) = -1.0 + Asys(4,1) = -1.0 + Asys(5,1) = -1.0 + Asys(6,1) = -1.0 - Asys(2,1) = -2.0*h1 + Asys(1,2) = -2.0*h1 Asys(2,2) = 2.0*h2 - Asys(2,3) = (2.0*h1 + h0) - Asys(2,4) = h1 - Asys(2,5) = -h2 - Asys(2,6) = -(2.0*h2 + h3) + Asys(3,2) = (2.0*h1 + h0) + Asys(4,2) = h1 + Asys(5,2) = -h2 + Asys(6,2) = -(2.0*h2 + h3) - Asys(3,1) = 3.0*h1_2 - Asys(3,2) = 3.0*h2_2 + Asys(1,3) = 3.0*h1_2 + Asys(2,3) = 3.0*h2_2 Asys(3,3) = -(3.0*h1_2 + h0*(3.0*h1 + h0)) ! = -((h0+h1)**3 - h1**3) / h0 - Asys(3,4) = - h1_2 - Asys(3,5) = - h2_2 - Asys(3,6) = -(3.0*h2_2 + h3*(3.0*h2 + h3)) ! = -((h2+h3)**3 - h2**3) / h3 + Asys(4,3) = - h1_2 + Asys(5,3) = - h2_2 + Asys(6,3) = -(3.0*h2_2 + h3*(3.0*h2 + h3)) ! = -((h2+h3)**3 - h2**3) / h3 - Asys(4,1) = -4.0*h1_3 - Asys(4,2) = 4.0*h2_3 - Asys(4,3) = (4.0*h1_3 + h0*(6.0*h1_2 + h0*(4.0*h1 + h0))) ! = ((h0+h1)**4 - h1**4) / h0 + Asys(1,4) = -4.0*h1_3 + Asys(2,4) = 4.0*h2_3 + Asys(3,4) = (4.0*h1_3 + h0*(6.0*h1_2 + h0*(4.0*h1 + h0))) ! = ((h0+h1)**4 - h1**4) / h0 Asys(4,4) = h1_3 - Asys(4,5) = - h2_3 - Asys(4,6) = -(4.0*h2_3 + h3*(6.0*h2_2 + h3*(4.0*h2 + h3))) ! = -((h2+h3)**4 - h2**4)/ h3 + Asys(5,4) = - h2_3 + Asys(6,4) = -(4.0*h2_3 + h3*(6.0*h2_2 + h3*(4.0*h2 + h3))) ! = -((h2+h3)**4 - h2**4)/ h3 - Asys(5,1) = 5.0*h1_4 - Asys(5,2) = 5.0*h2_4 - Asys(5,3) = -(5.0*h1_4 + h0*(10.0*h1_3 + h0*(10.0*h1_2 + h0*(5.0*h1 + h0)))) - Asys(5,4) = - h1_4 + Asys(1,5) = 5.0*h1_4 + Asys(2,5) = 5.0*h2_4 + Asys(3,5) = -(5.0*h1_4 + h0*(10.0*h1_3 + h0*(10.0*h1_2 + h0*(5.0*h1 + h0)))) + Asys(4,5) = - h1_4 Asys(5,5) = - h2_4 - Asys(5,6) = -(5.0*h2_4 + h3*(10.0*h2_3 + h3*(10.0*h2_2 + h3*(5.0*h2 + h3)))) + Asys(6,5) = -(5.0*h2_4 + h3*(10.0*h2_3 + h3*(10.0*h2_2 + h3*(5.0*h2 + h3)))) - Asys(6,1) = -6.0*h1_5 - Asys(6,2) = 6.0*h2_5 - Asys(6,3) = (6.0*h1_5 + h0*(15.0*h1_4 + h0*(20.0*h1_3 + h0*(15.0*h1_2 + h0*(6.0*h1 + h0))))) - Asys(6,4) = h1_5 - Asys(6,5) = - h2_5 + Asys(1,6) = -6.0*h1_5 + Asys(2,6) = 6.0*h2_5 + Asys(3,6) = (6.0*h1_5 + h0*(15.0*h1_4 + h0*(20.0*h1_3 + h0*(15.0*h1_2 + h0*(6.0*h1 + h0))))) + Asys(4,6) = h1_5 + Asys(5,6) = - h2_5 Asys(6,6) = -(6.0*h2_5 + h3*(15.0*h2_4 + h3*(20.0*h2_3 + h3*(15.0*h2_2 + h3*(6.0*h2 + h3))))) Bsys(:) = (/ -1.0, 0.0, 0.0, 0.0, 0.0, 0.0 /) - call solve_linear_system( Asys, Bsys, Csys, 6, .false. ) + call linear_solver( 6, Asys, Bsys, Csys ) alpha = Csys(1) beta = Csys(2) @@ -838,50 +838,50 @@ subroutine edge_values_implicit_h6( N, h, u, edge_val, h_neglect, answers_2018 ) ! Compute matrix entries Asys(1,1) = 1.0 - Asys(1,2) = 1.0 - Asys(1,3) = -1.0 - Asys(1,4) = -1.0 - Asys(1,5) = -1.0 - Asys(1,6) = -1.0 + Asys(2,1) = 1.0 + Asys(3,1) = -1.0 + Asys(4,1) = -1.0 + Asys(5,1) = -1.0 + Asys(6,1) = -1.0 - Asys(2,1) = -2.0* h01 + Asys(1,2) = -2.0* h01 Asys(2,2) = 0.0 - Asys(2,3) = (2.0*h1 + h0) - Asys(2,4) = h1 - Asys(2,5) = -h2 - Asys(2,6) = -(2.0*h2 + h3) + Asys(3,2) = (2.0*h1 + h0) + Asys(4,2) = h1 + Asys(5,2) = -h2 + Asys(6,2) = -(2.0*h2 + h3) - Asys(3,1) = 3.0 * h01_2 - Asys(3,2) = 0.0 + Asys(1,3) = 3.0 * h01_2 + Asys(2,3) = 0.0 Asys(3,3) = -(3.0*h1_2 + h0*(3.0*h1 + h0)) - Asys(3,4) = - h1_2 - Asys(3,5) = - h2_2 - Asys(3,6) = -(3.0*h2_2 + h3*(3.0*h2 + h3)) + Asys(4,3) = - h1_2 + Asys(5,3) = - h2_2 + Asys(6,3) = -(3.0*h2_2 + h3*(3.0*h2 + h3)) - Asys(4,1) = -4.0*h01_3 - Asys(4,2) = 0.0 - Asys(4,3) = (4.0*h1_3 + h0*(6.0*h1_2 + h0*(4.0*h1 + h0))) + Asys(1,4) = -4.0*h01_3 + Asys(2,4) = 0.0 + Asys(3,4) = (4.0*h1_3 + h0*(6.0*h1_2 + h0*(4.0*h1 + h0))) Asys(4,4) = h1_3 - Asys(4,5) = - h2_3 - Asys(4,6) = -(4.0*h2_3 + h3*(6.0*h2_2 + h3*(4.0*h2 + h3))) + Asys(5,4) = - h2_3 + Asys(6,4) = -(4.0*h2_3 + h3*(6.0*h2_2 + h3*(4.0*h2 + h3))) - Asys(5,1) = 5.0*(h01_2*h01_2) - Asys(5,2) = 0.0 - Asys(5,3) = -(5.0*h1_4 + h0*(10.0*h1_3 + h0*(10.0*h1_2 + h0*(5.0*h1 + h0)))) - Asys(5,4) = - h1_4 + Asys(1,5) = 5.0*(h01_2*h01_2) + Asys(2,5) = 0.0 + Asys(3,5) = -(5.0*h1_4 + h0*(10.0*h1_3 + h0*(10.0*h1_2 + h0*(5.0*h1 + h0)))) + Asys(4,5) = - h1_4 Asys(5,5) = - h2_4 - Asys(5,6) = -(5.0*h2_4 + h3*(10.0*h2_3 + h3*(10.0*h2_2 + h3*(5.0*h2 + h3)))) + Asys(6,5) = -(5.0*h2_4 + h3*(10.0*h2_3 + h3*(10.0*h2_2 + h3*(5.0*h2 + h3)))) - Asys(6,1) = -6.0*(h01_3*h01_2) - Asys(6,2) = 0.0 - Asys(6,3) = (6.0*h1_5 + h0*(15.0*h1_4 + h0*(20.0*h1_3 + h0*(15.0*h1_2 + h0*(6.0*h1 + h0))))) - Asys(6,4) = h1_5 - Asys(6,5) = - h2_5 + Asys(1,6) = -6.0*(h01_3*h01_2) + Asys(2,6) = 0.0 + Asys(3,6) = (6.0*h1_5 + h0*(15.0*h1_4 + h0*(20.0*h1_3 + h0*(15.0*h1_2 + h0*(6.0*h1 + h0))))) + Asys(4,6) = h1_5 + Asys(5,6) = - h2_5 Asys(6,6) = -(6.0*h2_5 + h3*(15.0*h2_4 + h3*(20.0*h2_3 + h3*(15.0*h2_2 + h3*(6.0*h2 + h3))))) Bsys(:) = (/ -1.0, 2.0*h1, -3.0*h1_2, 4.0*h1_3, -5.0*h1_4, 6.0*h1_5 /) - call solve_linear_system( Asys, Bsys, Csys, 6, .false. ) + call linear_solver( 6, Asys, Bsys, Csys ) alpha = Csys(1) beta = Csys(2) @@ -897,17 +897,17 @@ subroutine edge_values_implicit_h6( N, h, u, edge_val, h_neglect, answers_2018 ) do i = 1,6 dx = max( hMin, h(i) ) xavg = x(i) + 0.5*dx - Asys(i,1) = 1.0 - Asys(i,2) = xavg - Asys(i,3) = (xavg**2 + C1_12*dx**2) - Asys(i,4) = xavg * (xavg**2 + 0.25*dx**2) - Asys(i,5) = (xavg**4 + 0.5*xavg**2*dx**2 + 0.0125*dx**4) - Asys(i,6) = xavg * (xavg**4 + C5_6*xavg**2*dx**2 + 0.0625*dx**4) + Asys(1,i) = 1.0 + Asys(2,i) = xavg + Asys(3,i) = (xavg**2 + C1_12*dx**2) + Asys(4,i) = xavg * (xavg**2 + 0.25*dx**2) + Asys(5,i) = (xavg**4 + 0.5*xavg**2*dx**2 + 0.0125*dx**4) + Asys(6,i) = xavg * (xavg**4 + C5_6*xavg**2*dx**2 + 0.0625*dx**4) Bsys(i) = u(i) x(i+1) = x(i) + dx enddo - call solve_linear_system( Asys, Bsys, Csys, 6, .false. ) + call linear_solver( 6, Asys, Bsys, Csys ) tri_l(1) = 0.0 tri_d(1) = 1.0 @@ -928,50 +928,50 @@ subroutine edge_values_implicit_h6( N, h, u, edge_val, h_neglect, answers_2018 ) ! Compute matrix entries Asys(1,1) = 1.0 - Asys(1,2) = 1.0 - Asys(1,3) = -1.0 - Asys(1,4) = -1.0 - Asys(1,5) = -1.0 - Asys(1,6) = -1.0 + Asys(2,1) = 1.0 + Asys(3,1) = -1.0 + Asys(4,1) = -1.0 + Asys(5,1) = -1.0 + Asys(6,1) = -1.0 - Asys(2,1) = 0.0 + Asys(1,2) = 0.0 Asys(2,2) = 2.0*h23 - Asys(2,3) = (2.0*h1 + h0) - Asys(2,4) = h1 - Asys(2,5) = -h2 - Asys(2,6) = -(2.0*h2 + h3) + Asys(3,2) = (2.0*h1 + h0) + Asys(4,2) = h1 + Asys(5,2) = -h2 + Asys(6,2) = -(2.0*h2 + h3) - Asys(3,1) = 0.0 - Asys(3,2) = 3.0*h23_2 + Asys(1,3) = 0.0 + Asys(2,3) = 3.0*h23_2 Asys(3,3) = -(3.0*h1_2 + h0*(3.0*h1 + h0)) - Asys(3,4) = -h1_2 - Asys(3,5) = -h2_2 - Asys(3,6) = -(3.0*h2_2 + h3*(3.0*h2 + h3)) + Asys(4,3) = -h1_2 + Asys(5,3) = -h2_2 + Asys(6,3) = -(3.0*h2_2 + h3*(3.0*h2 + h3)) - Asys(4,1) = 0.0 - Asys(4,2) = 4.0*h23_3 - Asys(4,3) = (4.0*h1_3 + h0*(6.0*h1_2 + h0*(4.0*h1 + h0))) + Asys(1,4) = 0.0 + Asys(2,4) = 4.0*h23_3 + Asys(3,4) = (4.0*h1_3 + h0*(6.0*h1_2 + h0*(4.0*h1 + h0))) Asys(4,4) = h1_3 - Asys(4,5) = -h2_3 - Asys(4,6) = -(4.0*h2_3 + h3*(6.0*h2_2 + h3*(4.0*h2 + h3))) + Asys(5,4) = -h2_3 + Asys(6,4) = -(4.0*h2_3 + h3*(6.0*h2_2 + h3*(4.0*h2 + h3))) - Asys(5,1) = 0.0 - Asys(5,2) = 5.0*(h23_2*h23_2) - Asys(5,3) = -(5.0*h1_4 + h0*(10.0*h1_3 + h0*(10.0*h1_2 + h0*(5.0*h1 + h0)))) - Asys(5,4) = -h1_4 + Asys(1,5) = 0.0 + Asys(2,5) = 5.0*(h23_2*h23_2) + Asys(3,5) = -(5.0*h1_4 + h0*(10.0*h1_3 + h0*(10.0*h1_2 + h0*(5.0*h1 + h0)))) + Asys(4,5) = -h1_4 Asys(5,5) = -h2_4 - Asys(5,6) = -(5.0*h2_4 + h3*(10.0*h2_3 + h3*(10.0*h2_2 + h3*(5.0*h2 + h3)))) + Asys(6,5) = -(5.0*h2_4 + h3*(10.0*h2_3 + h3*(10.0*h2_2 + h3*(5.0*h2 + h3)))) - Asys(6,1) = 0.0 - Asys(6,2) = 6.0*(h23_3*h23_2) - Asys(6,3) = (6.0*h1_5 + h0*(15.0*h1_4 + h0*(20.0*h1_3 + h0*(15.0*h1_2 + h0*(6.0*h1 + h0))))) - Asys(6,4) = h1_5 - Asys(6,5) = -h2_5 + Asys(1,6) = 0.0 + Asys(2,6) = 6.0*(h23_3*h23_2) + Asys(3,6) = (6.0*h1_5 + h0*(15.0*h1_4 + h0*(20.0*h1_3 + h0*(15.0*h1_2 + h0*(6.0*h1 + h0))))) + Asys(4,6) = h1_5 + Asys(5,6) = -h2_5 Asys(6,6) = -(6.0*h2_5 + h3*(15.0*h2_4 + h3*(20.0*h2_3 + h3*(15.0*h2_2 + h3*(6.0*h2 + h3))))) Bsys(:) = (/ -1.0, -2.0*h2, -3.0*h2_2, -4.0*h2_3, -5.0*h2_4, -6.0*h2_5 /) - call solve_linear_system( Asys, Bsys, Csys, 6, .false. ) + call linear_solver( 6, Asys, Bsys, Csys ) alpha = Csys(1) beta = Csys(2) @@ -991,17 +991,17 @@ subroutine edge_values_implicit_h6( N, h, u, edge_val, h_neglect, answers_2018 ) do i = 1,6 dx = max( hMin, h(N-6+i) ) xavg = x(i) + 0.5 * dx - Asys(i,1) = 1.0 - Asys(i,2) = xavg - Asys(i,3) = (xavg**2 + C1_12*dx**2) - Asys(i,4) = xavg * (xavg**2 + 0.25*dx**2) - Asys(i,5) = (xavg**4 + 0.5*xavg**2*dx**2 + 0.0125*dx**4) - Asys(i,6) = xavg * (xavg**4 + C5_6*xavg**2*dx**2 + 0.0625*dx**4) + Asys(1,i) = 1.0 + Asys(2,i) = xavg + Asys(3,i) = (xavg**2 + C1_12*dx**2) + Asys(4,i) = xavg * (xavg**2 + 0.25*dx**2) + Asys(5,i) = (xavg**4 + 0.5*xavg**2*dx**2 + 0.0125*dx**4) + Asys(6,i) = xavg * (xavg**4 + C5_6*xavg**2*dx**2 + 0.0625*dx**4) Bsys(i) = u(N-6+i) x(i+1) = x(i) + dx enddo - call solve_linear_system( Asys, Bsys, Csys, 6, .false. ) + call linear_solver( 6, Asys, Bsys, Csys ) tri_l(N+1) = 0.0 tri_d(N+1) = 1.0 From 66c46c3866c1595309c742eb2712d6b8d1854e77 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Tue, 14 Jan 2020 17:55:23 -0500 Subject: [PATCH 026/316] Made regrid_edge_slopes more concise Used array syntax to set whole lines of the arrays being inverted in edge_values_implicit_h6, edge_slopes_implicit_h5 and elsewhere in the regridding code for shorter code that is easier to read. All answers are bitwise identical. --- src/ALE/regrid_edge_slopes.F90 | 206 ++++++++------------------------ src/ALE/regrid_edge_values.F90 | 212 +++++++++------------------------ 2 files changed, 102 insertions(+), 316 deletions(-) diff --git a/src/ALE/regrid_edge_slopes.F90 b/src/ALE/regrid_edge_slopes.F90 index bade56a46f..82996e3e44 100644 --- a/src/ALE/regrid_edge_slopes.F90 +++ b/src/ALE/regrid_edge_slopes.F90 @@ -166,11 +166,7 @@ subroutine edge_slopes_implicit_h3( N, h, u, edge_slopes, h_neglect, answers_201 dx = max(h_min, h(i) ) x(i+1) = x(i) + dx xavg = x(i) + 0.5*dx - Asys(1,i) = 1.0 - Asys(2,i) = xavg - Asys(3,i) = (xavg**2 + C1_12*dx**2) - Asys(4,i) = xavg * (xavg**2 + 0.25*dx**2) - ! Asys(1:4,i) = (/ 1.0, xavg, (xavg**2 + C1_12*dx**2), xavg * (xavg**2 + 0.25*dx**2) /) + Asys(1:4,i) = (/ 1.0, xavg, (xavg**2 + C1_12*dx**2), xavg * (xavg**2 + 0.25*dx**2) /) Bsys(i) = u(i) enddo @@ -207,11 +203,7 @@ subroutine edge_slopes_implicit_h3( N, h, u, edge_slopes, h_neglect, answers_201 dx = max(h_min, h(N+1-i) ) x(i+1) = x(i) + dx xavg = x(i) + 0.5*dx - Asys(1,i) = 1.0 - Asys(2,i) = xavg - Asys(3,i) = (xavg**2 + C1_12*dx**2) - Asys(4,i) = xavg * (xavg**2 + 0.25*dx**2) - ! Asys(1:4,i) = (/ 1.0, xavg, (xavg**2 + C1_12*dx**2), xavg * (xavg**2 + 0.25*dx**2) /) + Asys(1:4,i) = (/ 1.0, xavg, (xavg**2 + C1_12*dx**2), xavg * (xavg**2 + 0.25*dx**2) /) Bsys(i) = u(N+1-i) enddo @@ -322,53 +314,23 @@ subroutine edge_slopes_implicit_h5( N, h, u, edge_slopes, h_neglect, answers_201 h1_2 = h1 * h1 ; h1_3 = h1_2 * h1 ; h1_4 = h1_2 * h1_2 ; h1_5 = h1_3 * h1_2 h2_2 = h2 * h2 ; h2_3 = h2_2 * h2 ; h2_4 = h2_2 * h2_2 ; h2_5 = h2_3 * h2_2 - ! Compute matrix entries as described in Eq. (52) of White and Adcroft (2009) + ! Compute matrix entries as described in Eq. (52) of White and Adcroft (2009). The last 4 rows are ! Asys(1:6,n) = (/ -n*(n-1)*(-h1)**(n-2), -n*(n-1)*h1**(n-2), (-1)**(n-1) * ((h0+h1)**n - h0**n) / h0, & ! (-h1)**(n-1), h2**(n-1), ((h2+h3)**n - h2**n) / h3 /) - Asys(1,1) = 0.0 - Asys(2,1) = 0.0 - Asys(3,1) = 1.0 - Asys(4,1) = 1.0 - Asys(5,1) = 1.0 - Asys(6,1) = 1.0 - - Asys(1,2) = 2.0 - Asys(2,2) = 2.0 - Asys(3,2) = (2.0*h1 + h0) - Asys(4,2) = h1 - Asys(5,2) = -h2 - Asys(6,2) = -(2.0*h2 + h3) - - Asys(1,3) = 6.0*h1 - Asys(2,3) = -6.0* h2 - Asys(3,3) = (3.0*h1_2 + h0*(3.0*h1 + h0)) ! = ((h0+h1)**3 - h1**3) / h0 - Asys(4,3) = h1_2 - Asys(5,3) = h2_2 - Asys(6,3) = (3.0*h2_2 + h3*(3.0*h2 + h3)) ! = ((h2+h3)**3 - h2**3) / h3 - - Asys(1,4) = -12.0* h1_2 - Asys(2,4) = -12.0* h2_2 - Asys(3,4) = -(4.0*h1_3 + h0*(6.0*h1_2 + h0*(4.0*h1 + h0))) ! = -((h0+h1)**4 - h1**4) / h0 - Asys(4,4) = - h1_3 - Asys(5,4) = h2_3 - Asys(6,4) = (4.0*h2_3 + h3*(6.0*h2_2 + h3*(4.0*h2 + h3))) ! = ((h2+h3)**4 - h2**4)/ h3 - - Asys(1,5) = 20.0*h1_3 - Asys(2,5) = -20.0* h2_3 - Asys(3,5) = (5.0*h1_4 + h0*(10.0*h1_3 + h0*(10.0*h1_2 + h0*(5.0*h1 + h0)))) - Asys(4,5) = h1_4 - Asys(5,5) = h2_4 - Asys(6,5) = (5.0*h2_4 + h3*(10.0*h2_3 + h3*(10.0*h2_2 + h3*(5.0*h2 + h3)))) - - Asys(1,6) = -30.0*h1_4 - Asys(2,6) = -30.0*h2_4 - Asys(3,6) = -(6.0*h1_5 + h0*(15.0*h1_4 + h0*(20.0*h1_3 + h0*(15.0*h1_2 + h0*(6.0*h1 + h0))))) - Asys(4,6) = -h1_5 - Asys(5,6) = h2_5 - Asys(6,6) = (6.0*h2_5 + h3*(15.0*h2_4 + h3*(20.0*h2_3 + h3*(15.0*h2_2 + h3*(6.0*h2 + h3))))) - - Bsys(:) = (/ 0.0, -2.0, 0.0, 0.0, 0.0, 0.0 /) + Asys(1:6,1) = (/ 0.0, 0.0, 1.0, 1.0, 1.0, 1.0 /) + Asys(1:6,2) = (/ 2.0, 2.0, (2.0*h1 + h0), h1, -h2, -(2.0*h2 + h3) /) + Asys(1:6,3) = (/ 6.0*h1, -6.0* h2, (3.0*h1_2 + h0*(3.0*h1 + h0)), & + h1_2, h2_2, (3.0*h2_2 + h3*(3.0*h2 + h3)) /) + Asys(1:6,4) = (/ -12.0*h1_2, -12.0*h2_2, -(4.0*h1_3 + h0*(6.0*h1_2 + h0*(4.0*h1 + h0))), & + -h1_3, h2_3, (4.0*h2_3 + h3*(6.0*h2_2 + h3*(4.0*h2 + h3))) /) + Asys(1:6,5) = (/ 20.0*h1_3, -20.0*h2_3, (5.0*h1_4 + h0*(10.0*h1_3 + h0*(10.0*h1_2 + h0*(5.0*h1 + h0)))), & + h1_4, h2_4, (5.0*h2_4 + h3*(10.0*h2_3 + h3*(10.0*h2_2 + h3*(5.0*h2 + h3)))) /) + Asys(1:6,6) = (/ -30.0*h1_4, -30.0*h2_4, & + -(6.0*h1_5 + h0*(15.0*h1_4 + h0*(20.0*h1_3 + h0*(15.0*h1_2 + h0*(6.0*h1 + h0))))), & + -h1_5, h2_5, & + (6.0*h2_5 + h3*(15.0*h2_4 + h3*(20.0*h2_3 + h3*(15.0*h2_2 + h3*(6.0*h2 + h3))))) /) + Bsys(1:6) = (/ 0.0, -2.0, 0.0, 0.0, 0.0, 0.0 /) call linear_solver( 6, Asys, Bsys, Csys ) @@ -395,53 +357,19 @@ subroutine edge_slopes_implicit_h5( N, h, u, edge_slopes, h_neglect, answers_201 h01 = h0 + h1 ; h01_2 = h01 * h01 ! Compute matrix entries - Asys(1,1) = 0.0 - Asys(2,1) = 0.0 - Asys(3,1) = 1.0 - Asys(4,1) = 1.0 - Asys(5,1) = 1.0 - Asys(6,1) = 1.0 - - Asys(1,2) = 2.0 - Asys(2,2) = 2.0 - Asys(3,2) = (2.0*h1 + h0) - Asys(4,2) = h1 - Asys(5,2) = -h2 - Asys(6,2) = -(2.0*h2 + h3) - - Asys(1,3) = 6.0*h01 - Asys(2,3) = 0.0 - Asys(3,3) = (3.0*h1_2 + h0*(3.0*h1 + h0)) - Asys(4,3) = h1_2 - Asys(5,3) = h2_2 - Asys(6,3) = 3.0*h2_2 + h3*(3.0*h2 + h3) - -! Asys(1:6,1) = (/ 0.0, 0.0, 1.0, 1.0, 1.0, 1.0 /) -! Asys(1:6,2) = (/ 2.0, 2.0, 2.0*h1 + h0, h1, -h2, -(2.0*h2 + h3) /) -! Asys(1:6,3) = (/ 6.0*h01, 0.0, 3.0*h1_2 + h0*(3.0*h1 + h0), h1_2, h2_2, 3.0*h2_2 + h3*(3.0*h2 + h3) /) - - Asys(1,4) = -12.0*h01_2 - Asys(2,4) = 0.0 - Asys(3,4) = -(4.0*h1_3 + h0*(6.0*h1_2 + h0*(4.0*h1 + h0))) - Asys(4,4) = -h1_3 - Asys(5,4) = h2_3 - Asys(6,4) = 4.0*h2_3 + h3*(6.0*h2_2 + h3*(4.0*h2 + h3)) - - Asys(1,5) = 20.0*(h01*h01_2) - Asys(2,5) = 0.0 - Asys(3,5) = (5.0*h1_4 + h0*(10.0*h1_3 + h0*(10.0*h1_2 + h0*(5.0*h1 + h0)))) - Asys(4,5) = h1_4 - Asys(5,5) = h2_4 - Asys(6,5) = 5.0*h2_4 + h3*(10.0*h2_3 + h3*(10.0*h2_2 + h3*(5.0*h2 + h3))) - - Asys(1,6) = -30.0*(h01_2*h01_2) - Asys(2,6) = 0.0 - Asys(3,6) = -(6.0*h1_5 + h0*(15.0*h1_4 + h0*(20.0*h1_3 + h0*(15.0*h1_2 + h0*(6.0*h1 + h0))))) - Asys(4,6) = -h1_5 - Asys(5,6) = h2_5 - Asys(6,6) = 6.0*h2_5 + h3*(15.0*h2_4 + h3*(20.0*h2_3 + h3*(15.0*h2_2 + h3*(6.0*h2 + h3)))) - - Bsys(:) = (/ 0.0, -2.0, -6.0*h1, 12.0*h1_2, -20.0*h1_3, 30.0*h1_4 /) + Asys(1:6,1) = (/ 0.0, 0.0, 1.0, 1.0, 1.0, 1.0 /) + Asys(1:6,2) = (/ 2.0, 2.0, (2.0*h1 + h0), h1, -h2, -(2.0*h2 + h3) /) + Asys(1:6,3) = (/ 6.0*h01, 0.0, (3.0*h1_2 + h0*(3.0*h1 + h0)), & + h1_2, h2_2, (3.0*h2_2 + h3*(3.0*h2 + h3)) /) + Asys(1:6,4) = (/ -12.0*h01_2, 0.0, -(4.0*h1_3 + h0*(6.0*h1_2 + h0*(4.0*h1 + h0))), & + -h1_3, h2_3, (4.0*h2_3 + h3*(6.0*h2_2 + h3*(4.0*h2 + h3))) /) + Asys(1:6,5) = (/ 20.0*(h01*h01_2), 0.0, (5.0*h1_4 + h0*(10.0*h1_3 + h0*(10.0*h1_2 + h0*(5.0*h1 + h0)))), & + h1_4, h2_4, (5.0*h2_4 + h3*(10.0*h2_3 + h3*(10.0*h2_2 + h3*(5.0*h2 + h3)))) /) + Asys(1:6,6) = (/ -30.0*(h01_2*h01_2), 0.0, & + -(6.0*h1_5 + h0*(15.0*h1_4 + h0*(20.0*h1_3 + h0*(15.0*h1_2 + h0*(6.0*h1 + h0))))), & + -h1_5, h2_5, & + (6.0*h2_5 + h3*(15.0*h2_4 + h3*(20.0*h2_3 + h3*(15.0*h2_2 + h3*(6.0*h2 + h3))))) /) + Bsys(1:6) = (/ 0.0, -2.0, -6.0*h1, 12.0*h1_2, -20.0*h1_3, 30.0*h1_4 /) call linear_solver( 6, Asys, Bsys, Csys ) @@ -458,12 +386,9 @@ subroutine edge_slopes_implicit_h5( N, h, u, edge_slopes, h_neglect, answers_201 do i = 1,6 dx = h(i) xavg = x(i) + 0.5 * dx - Asys(1,i) = 1.0 - Asys(2,i) = xavg - Asys(3,i) = (xavg**2 + C1_12*dx**2) - Asys(4,i) = xavg * (xavg**2 + 0.25*dx**2) - Asys(5,i) = (xavg**4 + 0.5*xavg**2*dx**2 + 0.0125*dx**4) - Asys(6,i) = xavg * (xavg**4 + C5_6*xavg**2*dx**2 + 0.0625*dx**4) + Asys(1:6,i) = (/ 1.0, xavg, (xavg**2 + C1_12*dx**2), xavg * (xavg**2 + 0.25*dx**2), & + (xavg**4 + 0.5*xavg**2*dx**2 + 0.0125*dx**4), & + xavg * (xavg**4 + C5_6*xavg**2*dx**2 + 0.0625*dx**4) /) Bsys(i) = u(i) x(i+1) = x(i) + dx enddo @@ -479,7 +404,7 @@ subroutine edge_slopes_implicit_h5( N, h, u, edge_slopes, h_neglect, answers_201 tri_d(1) = 0.0 tri_d(1) = 1.0 tri_u(1) = 0.0 - tri_b(1) = evaluation_polynomial( Dsys, 5, x(1) ) ! first edge value + tri_b(1) = Csys(2) ! evaluation_polynomial( Dsys, 5, x(1) ) ! first edge value ! Use a left-biased stencil for the second to last row, as described in Eq. (54) of White and Adcroft (2009). @@ -495,49 +420,19 @@ subroutine edge_slopes_implicit_h5( N, h, u, edge_slopes, h_neglect, answers_201 h23 = h2 + h3 ; h23_2 = h23 * h23 ! Compute matrix entries - Asys(1,1) = 0.0 - Asys(2,1) = 0.0 - Asys(3,1) = 1.0 - Asys(4,1) = 1.0 - Asys(5,1) = 1.0 - Asys(6,1) = 1.0 - - Asys(1,2) = 2.0 - Asys(2,2) = 2.0 - Asys(3,2) = (2.0*h1 + h0) - Asys(4,2) = h1 - Asys(5,2) = -h2 - Asys(6,2) = -(2.0*h2 + h3) - - Asys(1,3) = 0.0 - Asys(2,3) = -6.0*h23 - Asys(3,3) = (3.0*h1_2 + h0*(3.0*h1 + h0)) - Asys(4,3) = h1_2 - Asys(5,3) = h2_2 - Asys(6,3) = 3.0*h2_2 + h3*(3.0*h2 + h3) - - Asys(1,4) = 0.0 - Asys(2,4) = -12.0*h23_2 - Asys(3,4) = -(4.0*h1_3 + h0*(6.0*h1_2 + h0*(4.0*h1 + h0))) - Asys(4,4) = -h1_3 - Asys(5,4) = h2_3 - Asys(6,4) = 4.0*h2_3 + h3*(6.0*h2_2 + h3*(4.0*h2 + h3)) - - Asys(1,5) = 0.0 - Asys(2,5) = -20.0*(h23*h23_2) - Asys(3,5) = (5.0*h1_4 + h0*(10.0*h1_3 + h0*(10.0*h1_2 + h0*(5.0*h1 + h0)))) - Asys(4,5) = h1_4 - Asys(5,5) = h2_4 - Asys(6,5) = 5.0*h2_4 + h3*(10.0*h2_3 + h3*(10.0*h2_2 + h3*(5.0*h2 + h3))) - - Asys(1,6) = 0.0 - Asys(2,6) = -30.0*(h23_2*h23_2) - Asys(3,6) = -(6.0*h1_5 + h0*(15.0*h1_4 + h0*(20.0*h1_3 + h0*(15.0*h1_2 + h0*(6.0*h1 + h0))))) - Asys(4,6) = -h1_5 - Asys(5,6) = h2_5 - Asys(6,6) = 6.0*h2_5 + h3*(15.0*h2_4 + h3*(20.0*h2_3 + h3*(15.0*h2_2 + h3*(6.0*h2 + h3)))) - - Bsys(:) = (/ 0.0, -2.0, 6.0*h2, 12.0*h2_2, 20.0*h2_3, 30.0*h2_4 /) + Asys(1:6,1) = (/ 0.0, 0.0, 1.0, 1.0, 1.0, 1.0 /) + Asys(1:6,2) = (/ 2.0, 2.0, (2.0*h1 + h0), h1, -h2, -(2.0*h2 + h3) /) + Asys(1:6,3) = (/ 0.0, -6.0*h23, (3.0*h1_2 + h0*(3.0*h1 + h0)), & + h1_2, h2_2, (3.0*h2_2 + h3*(3.0*h2 + h3)) /) + Asys(1:6,4) = (/ 0.0, -12.0*h23_2, -(4.0*h1_3 + h0*(6.0*h1_2 + h0*(4.0*h1 + h0))), & + -h1_3, h2_3, (4.0*h2_3 + h3*(6.0*h2_2 + h3*(4.0*h2 + h3))) /) + Asys(1:6,5) = (/ 0.0, -20.0*(h23*h23_2), (5.0*h1_4 + h0*(10.0*h1_3 + h0*(10.0*h1_2 + h0*(5.0*h1 + h0)))), & + h1_4, h2_4, (5.0*h2_4 + h3*(10.0*h2_3 + h3*(10.0*h2_2 + h3*(5.0*h2 + h3)))) /) + Asys(1:6,6) = (/ 0.0, -30.0*(h23_2*h23_2), & + -(6.0*h1_5 + h0*(15.0*h1_4 + h0*(20.0*h1_3 + h0*(15.0*h1_2 + h0*(6.0*h1 + h0))))), & + -h1_5, h2_5, & + (6.0*h2_5 + h3*(15.0*h2_4 + h3*(20.0*h2_3 + h3*(15.0*h2_2 + h3*(6.0*h2 + h3))))) /) + Bsys(1:6) = (/ 0.0, -2.0, 6.0*h2, 12.0*h2_2, 20.0*h2_3, 30.0*h2_4 /) call linear_solver( 6, Asys, Bsys, Csys ) @@ -554,12 +449,9 @@ subroutine edge_slopes_implicit_h5( N, h, u, edge_slopes, h_neglect, answers_201 do i = 1,6 dx = h(N-6+i) xavg = x(i) + 0.5*dx - Asys(1,i) = 1.0 - Asys(2,i) = xavg - Asys(3,i) = (xavg**2 + C1_12*dx**2) - Asys(4,i) = xavg * (xavg**2 + 0.25*dx**2) - Asys(5,i) = (xavg**4 + 0.5*xavg**2*dx**2 + 0.0125*dx**4) - Asys(6,i) = xavg * (xavg**4 + C5_6*xavg**2*dx**2 + 0.0625*dx**4) + Asys(1:6,i) = (/ 1.0, xavg, (xavg**2 + C1_12*dx**2), xavg * (xavg**2 + 0.25*dx**2), & + (xavg**4 + 0.5*xavg**2*dx**2 + 0.0125*dx**4), & + xavg * (xavg**4 + C5_6*xavg**2*dx**2 + 0.0625*dx**4) /) Bsys(i) = u(N-6+i) x(i+1) = x(i) + dx enddo diff --git a/src/ALE/regrid_edge_values.F90 b/src/ALE/regrid_edge_values.F90 index 80752f2d98..a4b788cd56 100644 --- a/src/ALE/regrid_edge_values.F90 +++ b/src/ALE/regrid_edge_values.F90 @@ -162,7 +162,7 @@ end subroutine check_discontinuous_edge_values !> Compute h2 edge values (explicit second order accurate) -!! in the same units as h. +!! in the same units as u. ! !! Compute edge values based on second-order explicit estimates. !! These estimates are based on a straight line spanning two cells and evaluated @@ -203,7 +203,7 @@ subroutine edge_values_explicit_h2( N, h, u, edge_val ) end subroutine edge_values_explicit_h2 !> Compute h4 edge values (explicit fourth order accurate) -!! in the same units as h. +!! in the same units as u. !! !! Compute edge values based on fourth-order explicit estimates. !! These estimates are based on a cubic interpolant spanning four cells @@ -241,7 +241,7 @@ subroutine edge_values_explicit_h4( N, h, u, edge_val, h_neglect, answers_2018 ) real, dimension(4) :: dz ! A temporary array of limited layer thicknesses [H] real, dimension(4) :: u_tmp ! A temporary array of cell average properties [A] real, parameter :: C1_12 = 1.0 / 12.0 - real :: dx, xavg ! Differences and averages of successive values of x [same units as h] + real :: dx, xavg ! Differences and averages of successive values of x [H] real, dimension(4,4) :: A ! values near the boundaries real, dimension(4) :: B, C real :: hNeglect ! A negligible thickness in the same units as h. @@ -370,7 +370,7 @@ subroutine edge_values_explicit_h4( N, h, u, edge_val, h_neglect, answers_2018 ) end subroutine edge_values_explicit_h4 !> Compute ih4 edge values (implicit fourth order accurate) -!! in the same units as h. +!! in the same units as u. !! !! Compute edge values based on fourth-order implicit estimates. !! @@ -682,8 +682,7 @@ subroutine end_value_h4(dz, u, Csys) end subroutine end_value_h4 -!> Compute ih6 edge values (implicit sixth order accurate) - !! in the same units as h. +!> Compute ih6 edge values (implicit sixth order accurate) in the same units as u. !! !! 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 @@ -733,14 +732,9 @@ subroutine edge_values_implicit_h6( N, h, u, edge_val, h_neglect, answers_2018 ) real :: h01, h01_2, h01_3 ! Summed thicknesses to various powers [H^n ~> m^n or kg^n m-2n] real :: h23, h23_2, h23_3 ! Summed thicknesses to various powers [H^n ~> m^n or kg^n m-2n] real :: hNeglect ! A negligible thickness [H]. - real :: d2, d3, d4, d5, d6 ! to set up the systems - real :: n2, n3, n4, n5, n6 ! used to compute the - real :: h1_2, h2_2 ! the coefficients of the - real :: h1_3, h2_3 ! tridiagonal system - real :: h1_4, h2_4 ! ... - real :: h1_5, h2_5 ! ... + real :: h1_2, h2_2, h1_3, h2_3 ! Cell widths raised to the 2nd and 3rd powers [H2] or [H3] + real :: h1_4, h2_4, h1_5, h2_5 ! Cell widths raised to the 4th and 5th powers [H4] or [H5] real :: alpha, beta ! stencil coefficients - real :: a, b, c, d ! " real, dimension(7) :: x ! Coordinate system with 0 at edges [same units as h] real, parameter :: C1_12 = 1.0 / 12.0 real, parameter :: C5_6 = 5.0 / 6.0 @@ -768,49 +762,19 @@ subroutine edge_values_implicit_h6( N, h, u, edge_val, h_neglect, answers_2018 ) h2_2 = h2 * h2 ; h2_3 = h2_2 * h2 ; h2_4 = h2_2 * h2_2 ; h2_5 = h2_3 * h2_2 ! Compute matrix entries as described in Eq. (48) of White and Adcroft (2009) - Asys(1,1) = 1.0 - Asys(2,1) = 1.0 - Asys(3,1) = -1.0 - Asys(4,1) = -1.0 - Asys(5,1) = -1.0 - Asys(6,1) = -1.0 - - Asys(1,2) = -2.0*h1 - Asys(2,2) = 2.0*h2 - Asys(3,2) = (2.0*h1 + h0) - Asys(4,2) = h1 - Asys(5,2) = -h2 - Asys(6,2) = -(2.0*h2 + h3) - - Asys(1,3) = 3.0*h1_2 - Asys(2,3) = 3.0*h2_2 - Asys(3,3) = -(3.0*h1_2 + h0*(3.0*h1 + h0)) ! = -((h0+h1)**3 - h1**3) / h0 - Asys(4,3) = - h1_2 - Asys(5,3) = - h2_2 - Asys(6,3) = -(3.0*h2_2 + h3*(3.0*h2 + h3)) ! = -((h2+h3)**3 - h2**3) / h3 - - Asys(1,4) = -4.0*h1_3 - Asys(2,4) = 4.0*h2_3 - Asys(3,4) = (4.0*h1_3 + h0*(6.0*h1_2 + h0*(4.0*h1 + h0))) ! = ((h0+h1)**4 - h1**4) / h0 - Asys(4,4) = h1_3 - Asys(5,4) = - h2_3 - Asys(6,4) = -(4.0*h2_3 + h3*(6.0*h2_2 + h3*(4.0*h2 + h3))) ! = -((h2+h3)**4 - h2**4)/ h3 - - Asys(1,5) = 5.0*h1_4 - Asys(2,5) = 5.0*h2_4 - Asys(3,5) = -(5.0*h1_4 + h0*(10.0*h1_3 + h0*(10.0*h1_2 + h0*(5.0*h1 + h0)))) - Asys(4,5) = - h1_4 - Asys(5,5) = - h2_4 - Asys(6,5) = -(5.0*h2_4 + h3*(10.0*h2_3 + h3*(10.0*h2_2 + h3*(5.0*h2 + h3)))) - - Asys(1,6) = -6.0*h1_5 - Asys(2,6) = 6.0*h2_5 - Asys(3,6) = (6.0*h1_5 + h0*(15.0*h1_4 + h0*(20.0*h1_3 + h0*(15.0*h1_2 + h0*(6.0*h1 + h0))))) - Asys(4,6) = h1_5 - Asys(5,6) = - h2_5 - Asys(6,6) = -(6.0*h2_5 + h3*(15.0*h2_4 + h3*(20.0*h2_3 + h3*(15.0*h2_2 + h3*(6.0*h2 + h3))))) - - Bsys(:) = (/ -1.0, 0.0, 0.0, 0.0, 0.0, 0.0 /) + Asys(1:6,1) = (/ 1.0, 1.0, -1.0, -1.0, -1.0, -1.0 /) + Asys(1:6,2) = (/ -2.0*h1, 2.0*h2, (2.0*h1 + h0), h1, -h2, -(2.0*h2 + h3) /) + Asys(1:6,3) = (/ 3.0*h1_2, 3.0*h2_2, -(3.0*h1_2 + h0*(3.0*h1 + h0)), & ! = -((h0+h1)**3 - h1**3) / h0 + -h1_2, -h2_2, -(3.0*h2_2 + h3*(3.0*h2 + h3)) /) ! = -((h2+h3)**3 - h2**3) / h3 + Asys(1:6,4) = (/ -4.0*h1_3, 4.0*h2_3, (4.0*h1_3 + h0*(6.0*h1_2 + h0*(4.0*h1 + h0))), & + h1_3, -h2_3, -(4.0*h2_3 + h3*(6.0*h2_2 + h3*(4.0*h2 + h3))) /) + Asys(1:6,5) = (/ 5.0*h1_4, 5.0*h2_4, -(5.0*h1_4 + h0*(10.0*h1_3 + h0*(10.0*h1_2 + h0*(5.0*h1 + h0)))), & + -h1_4, -h2_4, -(5.0*h2_4 + h3*(10.0*h2_3 + h3*(10.0*h2_2 + h3*(5.0*h2 + h3)))) /) + Asys(1:6,6) = (/ -6.0*h1_5, 6.0*h2_5, & + (6.0*h1_5 + h0*(15.0*h1_4 + h0*(20.0*h1_3 + h0*(15.0*h1_2 + h0*(6.0*h1 + h0))))), & + h1_5, -h2_5, & + -(6.0*h2_5 + h3*(15.0*h2_4 + h3*(20.0*h2_3 + h3*(15.0*h2_2 + h3*(6.0*h2 + h3))))) /) + Bsys(1:6) = (/ -1.0, 0.0, 0.0, 0.0, 0.0, 0.0 /) call linear_solver( 6, Asys, Bsys, Csys ) @@ -837,49 +801,19 @@ subroutine edge_values_implicit_h6( N, h, u, edge_val, h_neglect, answers_2018 ) h01 = h0 + h1 ; h01_2 = h01 * h01 ; h01_3 = h01 * h01_2 ! Compute matrix entries - Asys(1,1) = 1.0 - Asys(2,1) = 1.0 - Asys(3,1) = -1.0 - Asys(4,1) = -1.0 - Asys(5,1) = -1.0 - Asys(6,1) = -1.0 - - Asys(1,2) = -2.0* h01 - Asys(2,2) = 0.0 - Asys(3,2) = (2.0*h1 + h0) - Asys(4,2) = h1 - Asys(5,2) = -h2 - Asys(6,2) = -(2.0*h2 + h3) - - Asys(1,3) = 3.0 * h01_2 - Asys(2,3) = 0.0 - Asys(3,3) = -(3.0*h1_2 + h0*(3.0*h1 + h0)) - Asys(4,3) = - h1_2 - Asys(5,3) = - h2_2 - Asys(6,3) = -(3.0*h2_2 + h3*(3.0*h2 + h3)) - - Asys(1,4) = -4.0*h01_3 - Asys(2,4) = 0.0 - Asys(3,4) = (4.0*h1_3 + h0*(6.0*h1_2 + h0*(4.0*h1 + h0))) - Asys(4,4) = h1_3 - Asys(5,4) = - h2_3 - Asys(6,4) = -(4.0*h2_3 + h3*(6.0*h2_2 + h3*(4.0*h2 + h3))) - - Asys(1,5) = 5.0*(h01_2*h01_2) - Asys(2,5) = 0.0 - Asys(3,5) = -(5.0*h1_4 + h0*(10.0*h1_3 + h0*(10.0*h1_2 + h0*(5.0*h1 + h0)))) - Asys(4,5) = - h1_4 - Asys(5,5) = - h2_4 - Asys(6,5) = -(5.0*h2_4 + h3*(10.0*h2_3 + h3*(10.0*h2_2 + h3*(5.0*h2 + h3)))) - - Asys(1,6) = -6.0*(h01_3*h01_2) - Asys(2,6) = 0.0 - Asys(3,6) = (6.0*h1_5 + h0*(15.0*h1_4 + h0*(20.0*h1_3 + h0*(15.0*h1_2 + h0*(6.0*h1 + h0))))) - Asys(4,6) = h1_5 - Asys(5,6) = - h2_5 - Asys(6,6) = -(6.0*h2_5 + h3*(15.0*h2_4 + h3*(20.0*h2_3 + h3*(15.0*h2_2 + h3*(6.0*h2 + h3))))) - - Bsys(:) = (/ -1.0, 2.0*h1, -3.0*h1_2, 4.0*h1_3, -5.0*h1_4, 6.0*h1_5 /) + Asys(1:6,1) = (/ 1.0, 1.0, -1.0, -1.0, -1.0, -1.0 /) + Asys(1:6,2) = (/ -2.0*h01, 0.0, (2.0*h1 + h0), h1, -h2, -(2.0*h2 + h3) /) + Asys(1:6,3) = (/ 3.0*h01_2, 0.0, -(3.0*h1_2 + h0*(3.0*h1 + h0)), & + -h1_2, -h2_2, -(3.0*h2_2 + h3*(3.0*h2 + h3)) /) + Asys(1:6,4) = (/ -4.0*h01_3, 0.0, (4.0*h1_3 + h0*(6.0*h1_2 + h0*(4.0*h1 + h0))), & + h1_3, -h2_3, -(4.0*h2_3 + h3*(6.0*h2_2 + h3*(4.0*h2 + h3))) /) + Asys(1:6,5) = (/ 5.0*(h01_2*h01_2), 0.0, -(5.0*h1_4 + h0*(10.0*h1_3 + h0*(10.0*h1_2 + h0*(5.0*h1 + h0)))), & + -h1_4, -h2_4, -(5.0*h2_4 + h3*(10.0*h2_3 + h3*(10.0*h2_2 + h3*(5.0*h2 + h3)))) /) + Asys(1:6,6) = (/ -6.0*(h01_3*h01_2), 0.0, & + (6.0*h1_5 + h0*(15.0*h1_4 + h0*(20.0*h1_3 + h0*(15.0*h1_2 + h0*(6.0*h1 + h0))))), & + h1_5, - h2_5, & + -(6.0*h2_5 + h3*(15.0*h2_4 + h3*(20.0*h2_3 + h3*(15.0*h2_2 + h3*(6.0*h2 + h3))))) /) + Bsys(1:6) = (/ -1.0, 2.0*h1, -3.0*h1_2, 4.0*h1_3, -5.0*h1_4, 6.0*h1_5 /) call linear_solver( 6, Asys, Bsys, Csys ) @@ -897,12 +831,9 @@ subroutine edge_values_implicit_h6( N, h, u, edge_val, h_neglect, answers_2018 ) do i = 1,6 dx = max( hMin, h(i) ) xavg = x(i) + 0.5*dx - Asys(1,i) = 1.0 - Asys(2,i) = xavg - Asys(3,i) = (xavg**2 + C1_12*dx**2) - Asys(4,i) = xavg * (xavg**2 + 0.25*dx**2) - Asys(5,i) = (xavg**4 + 0.5*xavg**2*dx**2 + 0.0125*dx**4) - Asys(6,i) = xavg * (xavg**4 + C5_6*xavg**2*dx**2 + 0.0625*dx**4) + Asys(1:6,i) = (/ 1.0, xavg, (xavg**2 + C1_12*dx**2), xavg * (xavg**2 + 0.25*dx**2), & + (xavg**4 + 0.5*xavg**2*dx**2 + 0.0125*dx**4), & + xavg * (xavg**4 + C5_6*xavg**2*dx**2 + 0.0625*dx**4) /) Bsys(i) = u(i) x(i+1) = x(i) + dx enddo @@ -927,63 +858,29 @@ subroutine edge_values_implicit_h6( N, h, u, edge_val, h_neglect, answers_2018 ) h23 = h2 + h3 ; h23_2 = h23 * h23 ; h23_3 = h23 * h23_2 ! Compute matrix entries - Asys(1,1) = 1.0 - Asys(2,1) = 1.0 - Asys(3,1) = -1.0 - Asys(4,1) = -1.0 - Asys(5,1) = -1.0 - Asys(6,1) = -1.0 - - Asys(1,2) = 0.0 - Asys(2,2) = 2.0*h23 - Asys(3,2) = (2.0*h1 + h0) - Asys(4,2) = h1 - Asys(5,2) = -h2 - Asys(6,2) = -(2.0*h2 + h3) - - Asys(1,3) = 0.0 - Asys(2,3) = 3.0*h23_2 - Asys(3,3) = -(3.0*h1_2 + h0*(3.0*h1 + h0)) - Asys(4,3) = -h1_2 - Asys(5,3) = -h2_2 - Asys(6,3) = -(3.0*h2_2 + h3*(3.0*h2 + h3)) - - Asys(1,4) = 0.0 - Asys(2,4) = 4.0*h23_3 - Asys(3,4) = (4.0*h1_3 + h0*(6.0*h1_2 + h0*(4.0*h1 + h0))) - Asys(4,4) = h1_3 - Asys(5,4) = -h2_3 - Asys(6,4) = -(4.0*h2_3 + h3*(6.0*h2_2 + h3*(4.0*h2 + h3))) - - Asys(1,5) = 0.0 - Asys(2,5) = 5.0*(h23_2*h23_2) - Asys(3,5) = -(5.0*h1_4 + h0*(10.0*h1_3 + h0*(10.0*h1_2 + h0*(5.0*h1 + h0)))) - Asys(4,5) = -h1_4 - Asys(5,5) = -h2_4 - Asys(6,5) = -(5.0*h2_4 + h3*(10.0*h2_3 + h3*(10.0*h2_2 + h3*(5.0*h2 + h3)))) - - Asys(1,6) = 0.0 - Asys(2,6) = 6.0*(h23_3*h23_2) - Asys(3,6) = (6.0*h1_5 + h0*(15.0*h1_4 + h0*(20.0*h1_3 + h0*(15.0*h1_2 + h0*(6.0*h1 + h0))))) - Asys(4,6) = h1_5 - Asys(5,6) = -h2_5 - Asys(6,6) = -(6.0*h2_5 + h3*(15.0*h2_4 + h3*(20.0*h2_3 + h3*(15.0*h2_2 + h3*(6.0*h2 + h3))))) - - Bsys(:) = (/ -1.0, -2.0*h2, -3.0*h2_2, -4.0*h2_3, -5.0*h2_4, -6.0*h2_5 /) + Asys(1:6,1) = (/ 1.0, 1.0, -1.0, -1.0, -1.0, -1.0 /) + Asys(1:6,2) = (/ 0.0, 2.0*h23, (2.0*h1 + h0), h1, -h2, -(2.0*h2 + h3) /) + Asys(1:6,3) = (/ 0.0, 3.0*h23_2, -(3.0*h1_2 + h0*(3.0*h1 + h0)), & + -h1_2, -h2_2, -(3.0*h2_2 + h3*(3.0*h2 + h3)) /) + Asys(1:6,4) = (/ 0.0, 4.0*h23_3, (4.0*h1_3 + h0*(6.0*h1_2 + h0*(4.0*h1 + h0))), & + h1_3, -h2_3, -(4.0*h2_3 + h3*(6.0*h2_2 + h3*(4.0*h2 + h3))) /) + Asys(1:6,5) = (/ 0.0, 5.0*(h23_2*h23_2), -(5.0*h1_4 + h0*(10.0*h1_3 + h0*(10.0*h1_2 + h0*(5.0*h1 + h0)))), & + -h1_4, -h2_4, -(5.0*h2_4 + h3*(10.0*h2_3 + h3*(10.0*h2_2 + h3*(5.0*h2 + h3)))) /) + Asys(1:6,6) = (/ 0.0, 6.0*(h23_3*h23_2), & + (6.0*h1_5 + h0*(15.0*h1_4 + h0*(20.0*h1_3 + h0*(15.0*h1_2 + h0*(6.0*h1 + h0))))), & + h1_5, -h2_5, & + -(6.0*h2_5 + h3*(15.0*h2_4 + h3*(20.0*h2_3 + h3*(15.0*h2_2 + h3*(6.0*h2 + h3))))) /) + Bsys(1:6) = (/ -1.0, -2.0*h2, -3.0*h2_2, -4.0*h2_3, -5.0*h2_4, -6.0*h2_5 /) call linear_solver( 6, Asys, Bsys, Csys ) alpha = Csys(1) beta = Csys(2) - a = Csys(3) - b = Csys(4) - c = Csys(5) - d = Csys(6) tri_l(N) = alpha tri_d(N) = 1.0 tri_u(N) = beta - tri_b(N) = a * u(N-3) + b * u(N-2) + c * u(N-1) + d * u(N) + tri_b(N) = Csys(3) * u(N-3) + Csys(4) * u(N-2) + Csys(5) * u(N-1) + Csys(6) * u(N) ! Boundary conditions: right boundary hMin = max( hNeglect, hMinFrac*(h(N-3) + h(N-2)) + ((h(N-1) + h(N)) + (h(N-5) + h(N-4))) ) @@ -991,12 +888,9 @@ subroutine edge_values_implicit_h6( N, h, u, edge_val, h_neglect, answers_2018 ) do i = 1,6 dx = max( hMin, h(N-6+i) ) xavg = x(i) + 0.5 * dx - Asys(1,i) = 1.0 - Asys(2,i) = xavg - Asys(3,i) = (xavg**2 + C1_12*dx**2) - Asys(4,i) = xavg * (xavg**2 + 0.25*dx**2) - Asys(5,i) = (xavg**4 + 0.5*xavg**2*dx**2 + 0.0125*dx**4) - Asys(6,i) = xavg * (xavg**4 + C5_6*xavg**2*dx**2 + 0.0625*dx**4) + Asys(1:6,i) = (/ 1.0, xavg, (xavg**2 + C1_12*dx**2), xavg * (xavg**2 + 0.25*dx**2), & + (xavg**4 + 0.5*xavg**2*dx**2 + 0.0125*dx**4), & + xavg * (xavg**4 + C5_6*xavg**2*dx**2 + 0.0625*dx**4) /) Bsys(i) = u(N-6+i) x(i+1) = x(i) + dx enddo From dc1bed6bd9bc29fc8cf223d49fad6f2fe46b8b73 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Tue, 14 Jan 2020 19:00:57 -0500 Subject: [PATCH 027/316] +Merged regrid_edge_slopes into regrid_edge_values Merged the regrid_edge_slopes module into regrid_edge_values, and also added the two subroutines from regrid_solvers that are intended to be retained to the same module. Also added some additional error handling to linear_solver. All answers are bitwise identical, but the module structure has been streamlined and the locations of some public interfaces have changed. --- src/ALE/MOM_remapping.F90 | 2 +- src/ALE/regrid_edge_slopes.F90 | 484 --------------------------- src/ALE/regrid_edge_values.F90 | 585 ++++++++++++++++++++++++++++++++- src/ALE/regrid_interp.F90 | 2 +- 4 files changed, 579 insertions(+), 494 deletions(-) delete mode 100644 src/ALE/regrid_edge_slopes.F90 diff --git a/src/ALE/MOM_remapping.F90 b/src/ALE/MOM_remapping.F90 index 5c2bc9918c..d886015115 100644 --- a/src/ALE/MOM_remapping.F90 +++ b/src/ALE/MOM_remapping.F90 @@ -8,7 +8,7 @@ module MOM_remapping use MOM_string_functions, only : uppercase use regrid_edge_values, only : edge_values_explicit_h4, edge_values_implicit_h4 use regrid_edge_values, only : edge_values_implicit_h4, edge_values_implicit_h6 -use regrid_edge_slopes, only : edge_slopes_implicit_h3, edge_slopes_implicit_h5 +use regrid_edge_values, only : edge_slopes_implicit_h3, edge_slopes_implicit_h5 use PCM_functions, only : PCM_reconstruction use PLM_functions, only : PLM_reconstruction, PLM_boundary_extrapolation use PPM_functions, only : PPM_reconstruction, PPM_boundary_extrapolation diff --git a/src/ALE/regrid_edge_slopes.F90 b/src/ALE/regrid_edge_slopes.F90 deleted file mode 100644 index 82996e3e44..0000000000 --- a/src/ALE/regrid_edge_slopes.F90 +++ /dev/null @@ -1,484 +0,0 @@ -!> Routines that estimate edge slopes to be used in -!! high-order reconstruction schemes. -module regrid_edge_slopes - -! This file is part of MOM6. See LICENSE.md for the license. - -use regrid_solvers, only : solve_linear_system, solve_tridiagonal_system -use regrid_solvers, only : solve_diag_dominant_tridiag, linear_solver -use polynomial_functions, only : evaluation_polynomial - -implicit none ; private - -public edge_slopes_implicit_h3 -public edge_slopes_implicit_h5 - -! Specifying a dimensional parameter value, as is done here, is a terrible idea. -real, parameter :: hNeglect_dflt = 1.E-30 !< Default negligible cell thickness -real, parameter :: hMinFrac = 1.e-5 !< A minimum fraction for min(h)/sum(h) - -contains - -!------------------------------------------------------------------------------ -!> Compute ih3 edge slopes (implicit third order accurate) -!! 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 -!! -!! Third-order implicit estimates of edge slopes are based on a two-cell -!! stencil. A tridiagonal system is set up and is based on expressing the -!! edge slopes in terms of neighboring cell averages. The generic -!! relationship is -!! -!! \f[ -!! \alpha u'_{i-1/2} + u'_{i+1/2} + \beta u'_{i+3/2} = -!! a \bar{u}_i + b \bar{u}_{i+1} -!! \f] -!! -!! and the stencil looks like this -!! -!! i i+1 -!! ..--o------o------o--.. -!! i-1/2 i+1/2 i+3/2 -!! -!! In this routine, the coefficients \f$\alpha\f$, \f$\beta\f$, a and b are computed, -!! the tridiagonal system is built, boundary conditions are prescribed and -!! the system is solved to yield edge-slope estimates. -!! -!! There are N+1 unknowns and we are able to write N-1 equations. The -!! boundary conditions close the system. -subroutine edge_slopes_implicit_h3( N, h, u, edge_slopes, h_neglect, answers_2018 ) - integer, intent(in) :: N !< Number of cells - real, dimension(N), intent(in) :: h !< cell widths [H] - real, dimension(N), intent(in) :: u !< cell average properties in arbitrary units [A] - real, dimension(N,2), intent(inout) :: edge_slopes !< Returned edge slopes [A H-1]; the - !! second index is for the two edges of each cell. - real, optional, intent(in) :: h_neglect !< A negligibly small width [H] - logical, optional, intent(in) :: answers_2018 !< If true use older, less acccurate expressions. - ! Local variables - integer :: i, j ! loop indexes - real :: h0, h1 ! cell widths [H or nondim] - real :: h0_2, h1_2, h0h1 ! products of cell widths [H2 or nondim] - real :: h0_3, h1_3 ! products of three cell widths [H3 or nondim] - real :: h_min ! A minimal cell width [H] - real :: d ! A temporary variable [H3] - real :: I_d ! A temporary variable [nondim] - real :: I_h ! Inverses of thicknesses [H-1] - real :: alpha, beta ! stencil coefficients [nondim] - real :: a, b ! weights of cells [H-1] - real, parameter :: C1_12 = 1.0 / 12.0 - real, dimension(5) :: x ! Coordinate system with 0 at edges [H] - real :: dx, xavg ! Differences and averages of successive values of x [H] - real, dimension(4,4) :: Asys ! matrix used to find boundary conditions - real, dimension(4) :: Bsys, Csys - real, dimension(3) :: Dsys - real, dimension(N+1) :: tri_l, & ! tridiagonal system (lower diagonal) [nondim] - tri_d, & ! tridiagonal system (middle diagonal) [nondim] - tri_c, & ! tridiagonal system central value, with tri_d = tri_c+tri_l+tri_u - tri_u, & ! tridiagonal system (upper diagonal) [nondim] - tri_b, & ! tridiagonal system (right hand side) [A H-1] - tri_x ! tridiagonal system (solution vector) [A H-1] - real :: hNeglect ! A negligible thickness [H]. - real :: hNeglect3 ! hNeglect^3 [H3]. - logical :: use_2018_answers ! If true use older, less acccurate expressions. - - hNeglect = hNeglect_dflt ; if (present(h_neglect)) hNeglect = h_neglect - hNeglect3 = hNeglect**3 - use_2018_answers = .true. ; if (present(answers_2018)) use_2018_answers = answers_2018 - - ! Loop on cells (except last one) - do i = 1,N-1 - - if (use_2018_answers) then - ! Get cell widths - h0 = h(i) - h1 = h(i+1) - - ! Auxiliary calculations - h0h1 = h0 * h1 - h0_2 = h0 * h0 - h1_2 = h1 * h1 - h0_3 = h0_2 * h0 - h1_3 = h1_2 * h1 - - d = 4.0 * h0h1 * ( h0 + h1 ) + h1_3 + h0_3 - - ! Coefficients - alpha = h1 * (h0_2 + h0h1 - h1_2) / ( d + hNeglect3 ) - beta = h0 * (h1_2 + h0h1 - h0_2) / ( d + hNeglect3 ) - a = -12.0 * h0h1 / ( d + hNeglect3 ) - b = -a - - tri_l(i+1) = alpha - tri_d(i+1) = 1.0 - tri_u(i+1) = beta - - tri_b(i+1) = a * u(i) + b * u(i+1) - else - ! Get cell widths - h0 = max(h(i), hNeglect) - h1 = max(h(i+1), hNeglect) - - I_h = 1.0 / (h0 + h1) - h0 = h0 * I_h ; h1 = h1 * I_h - - h0h1 = h0 * h1 ; h0_2 = h0 * h0 ; h1_2 = h1 * h1 - h0_3 = h0_2 * h0 ; h1_3 = h1_2 * h1 - - I_d = 1.0 / (4.0 * h0h1 * ( h0 + h1 ) + h1_3 + h0_3) ! = 1 / ((h0 + h1)**3 + h0*h1*(h0 + h1)) - - ! Set the tridiagonal coefficients - tri_l(i+1) = (h1 * ((h0_2 + h0h1) - h1_2)) * I_d - ! tri_d(i+1) = 1.0 - tri_c(i+1) = 2.0 * ((h0_2 + h1_2) * (h0 + h1)) * I_d - tri_u(i+1) = (h0 * ((h1_2 + h0h1) - h0_2)) * I_d - ! The following expressions have been simplified using the nondimensionalization above: - ! I_d = 1.0 / (1.0 + h0h1) - ! tri_l(i+1) = (h0h1 - h1_3) * I_d - ! tri_c(i+1) = 2.0 * (h0_2 + h1_2) * I_d - ! tri_u(i+1) = (h0h1 - h0_3) * I_d - - tri_b(i+1) = 12.0 * (h0h1 * I_d) * ((u(i+1) - u(i)) * I_h) - endif - - enddo ! end loop on cells - - ! Boundary conditions: set the first edge slope - if (use_2018_answers) then - x(1) = 0.0 - do i = 1,4 - dx = h(i) - x(i+1) = x(i) + dx - do j = 1,4 ; Asys(i,j) = ( (x(i+1)**j) - (x(i)**j) ) / j ; enddo - Bsys(i) = u(i) * dx - enddo - - call solve_linear_system( Asys, Bsys, Csys, 4 ) - - Dsys(1) = Csys(2) ; Dsys(2) = 2.0 * Csys(3) ; Dsys(3) = 3.0 * Csys(4) - tri_b(1) = evaluation_polynomial( Dsys, 3, x(1) ) ! Set the first edge slope - tri_d(1) = 1.0 - else ! Use expressions with less sensitivity to roundoff - h_min = max( hNeglect, hMinFrac * ((h(1) + h(2)) + (h(3) + h(4))) ) - x(1) = 0.0 - do i = 1,4 - dx = max(h_min, h(i) ) - x(i+1) = x(i) + dx - xavg = x(i) + 0.5*dx - Asys(1:4,i) = (/ 1.0, xavg, (xavg**2 + C1_12*dx**2), xavg * (xavg**2 + 0.25*dx**2) /) - Bsys(i) = u(i) - enddo - - call linear_solver( 4, Asys, Bsys, Csys ) - - ! Set the first edge slope - tri_b(1) = Csys(2) ! + x(1)*(2.0*Csys(3) + x(1)*(3.0*Csys(4))) - tri_c(1) = 1.0 - endif - tri_u(1) = 0.0 ! tri_l(1) = 0.0 - - ! Boundary conditions: set the last edge slope - if (use_2018_answers) then - x(1) = 0.0 - do i = 1,4 - dx = h(N-4+i) - x(i+1) = x(i) + dx - do j = 1,4 ; Asys(i,j) = ( (x(i+1)**j) - (x(i)**j) ) / j ; enddo - Bsys(i) = u(N-4+i) * dx - enddo - - call solve_linear_system( Asys, Bsys, Csys, 4 ) - - Dsys(1) = Csys(2) ; Dsys(2) = 2.0 * Csys(3) ; Dsys(3) = 3.0 * Csys(4) - ! Set the last edge slope - tri_b(N+1) = evaluation_polynomial( Dsys, 3, x(5) ) - tri_d(N+1) = 1.0 - else - ! Use expressions with less sensitivity to roundoff, including using a coordinate - ! system that sets the origin at the last interface in the domain. - h_min = max( hNeglect, hMinFrac * ((h(N-3) + h(N-2)) + (h(N-1) + h(N))) ) - x(1) = 0.0 - do i = 1,4 - dx = max(h_min, h(N+1-i) ) - x(i+1) = x(i) + dx - xavg = x(i) + 0.5*dx - Asys(1:4,i) = (/ 1.0, xavg, (xavg**2 + C1_12*dx**2), xavg * (xavg**2 + 0.25*dx**2) /) - Bsys(i) = u(N+1-i) - enddo - - call linear_solver( 4, Asys, Bsys, Csys ) - - ! Set the last edge slope - tri_b(N+1) = Csys(2) - tri_c(N+1) = 1.0 - endif - tri_l(N+1) = 0.0 ! tri_u(N+1) = 0.0 - - ! Solve tridiagonal system and assign edge slopes - if (use_2018_answers) then - call solve_tridiagonal_system( tri_l, tri_d, tri_u, tri_b, tri_x, N+1 ) - else - call solve_diag_dominant_tridiag( tri_l, tri_c, tri_u, tri_b, tri_x, N+1 ) - endif - - do i = 2,N - edge_slopes(i,1) = tri_x(i) - edge_slopes(i-1,2) = tri_x(i) - enddo - edge_slopes(1,1) = tri_x(1) - edge_slopes(N,2) = tri_x(N+1) - -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, answers_2018 ) - integer, intent(in) :: N !< Number of cells - real, dimension(N), intent(in) :: h !< cell widths [H] - real, dimension(N), intent(in) :: u !< cell average properties in arbitrary units [A] - real, dimension(N,2), intent(inout) :: edge_slopes !< Returned edge slopes [A H-1]; the - !! second index is for the two edges of each cell. - real, optional, intent(in) :: h_neglect !< A negligibly small width [H] - logical, optional, intent(in) :: answers_2018 !< If true use older, less acccurate expressions. -! ----------------------------------------------------------------------------- -! 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 -! expressing the edge slopes in terms of neighboring cell averages. -! -! The generic relationship is -! -! \alpha u'_{i-1/2} + u'_{i+1/2} + \beta u'_{i+3/2} = -! a \bar{u}_{i-1} + b \bar{u}_i + c \bar{u}_{i+1} + d \bar{u}_{i+2} -! -! and the stencil looks like this -! -! i-1 i i+1 i+2 -! ..--o------o------o------o------o--.. -! i-1/2 i+1/2 i+3/2 -! -! In this routine, the coefficients \alpha, \beta, a, b, c and d are -! computed, the tridiagonal system is built, boundary conditions are -! prescribed and the system is solved to yield edge-value estimates. -! -! Note that the centered stencil only applies to edges 3 to N-1 (edges are -! numbered 1 to n+1), which yields N-3 equations for N+1 unknowns. Two other -! equations are written by using a right-biased stencil for edge 2 and a -! left-biased stencil for edge N. The prescription of boundary conditions -! (using sixth-order polynomials) closes the system. -! -! CAUTION: For each edge, in order to determine the coefficients of the -! implicit expression, a 6x6 linear system is solved. This may -! become computationally expensive if regridding is carried out -! often. Figuring out closed-form expressions for these coefficients -! on nonuniform meshes turned out to be intractable. -! ----------------------------------------------------------------------------- - - ! Local variables - real :: h0, h1, h2, h3 ! cell widths [H] - real :: hMin ! The minimum thickness used in these calculations [H] - real :: h01, h01_2 ! Summed thicknesses to various powers [H^n ~> m^n or kg^n m-2n] - real :: h23, h23_2 ! Summed thicknesses to various powers [H^n ~> m^n or kg^n m-2n] - real :: hNeglect ! A negligible thickness [H]. - real :: h1_2, h2_2 ! the coefficients of the - real :: h1_3, h2_3 ! tridiagonal system - real :: h1_4, h2_4 ! ... - real :: h1_5, h2_5 ! ... - real :: alpha, beta ! stencil coefficients - real, dimension(7) :: x ! Coordinate system with 0 at edges [same units as h] - real, parameter :: C1_12 = 1.0 / 12.0 - real, parameter :: C5_6 = 5.0 / 6.0 - real :: dx, xavg ! Differences and averages of successive values of x [same units as h] - real, dimension(6,6) :: Asys ! matrix used to find boundary conditions - real, dimension(6) :: Bsys, Csys ! ... - real, dimension(5) :: Dsys ! derivative - real, dimension(N+1) :: tri_l, & ! trid. system (lower diagonal) - tri_d, & ! trid. system (middle diagonal) - tri_u, & ! trid. system (upper diagonal) - tri_b, & ! trid. system (unknowns vector) - tri_x ! trid. system (rhs) - real :: h_Min_Frac = 1.0e-4 - integer :: i, j, k ! loop indexes - - hNeglect = hNeglect_dflt ; if (present(h_neglect)) hNeglect = h_neglect - - ! Loop on cells (except the first and last ones) - do k = 2,N-2 - ! Store temporary cell widths, avoiding singularities from zero thicknesses or extreme changes. - hMin = max(hNeglect, h_Min_Frac*((h(k-1) + h(k)) + (h(k+1) + h(k+2)))) - h0 = max(h(k-1), hMin) ; h1 = max(h(k), hMin) - h2 = max(h(k+1), hMin) ; h3 = max(h(k+2), hMin) - - ! Auxiliary calculations - h1_2 = h1 * h1 ; h1_3 = h1_2 * h1 ; h1_4 = h1_2 * h1_2 ; h1_5 = h1_3 * h1_2 - h2_2 = h2 * h2 ; h2_3 = h2_2 * h2 ; h2_4 = h2_2 * h2_2 ; h2_5 = h2_3 * h2_2 - - ! Compute matrix entries as described in Eq. (52) of White and Adcroft (2009). The last 4 rows are - ! Asys(1:6,n) = (/ -n*(n-1)*(-h1)**(n-2), -n*(n-1)*h1**(n-2), (-1)**(n-1) * ((h0+h1)**n - h0**n) / h0, & - ! (-h1)**(n-1), h2**(n-1), ((h2+h3)**n - h2**n) / h3 /) - - Asys(1:6,1) = (/ 0.0, 0.0, 1.0, 1.0, 1.0, 1.0 /) - Asys(1:6,2) = (/ 2.0, 2.0, (2.0*h1 + h0), h1, -h2, -(2.0*h2 + h3) /) - Asys(1:6,3) = (/ 6.0*h1, -6.0* h2, (3.0*h1_2 + h0*(3.0*h1 + h0)), & - h1_2, h2_2, (3.0*h2_2 + h3*(3.0*h2 + h3)) /) - Asys(1:6,4) = (/ -12.0*h1_2, -12.0*h2_2, -(4.0*h1_3 + h0*(6.0*h1_2 + h0*(4.0*h1 + h0))), & - -h1_3, h2_3, (4.0*h2_3 + h3*(6.0*h2_2 + h3*(4.0*h2 + h3))) /) - Asys(1:6,5) = (/ 20.0*h1_3, -20.0*h2_3, (5.0*h1_4 + h0*(10.0*h1_3 + h0*(10.0*h1_2 + h0*(5.0*h1 + h0)))), & - h1_4, h2_4, (5.0*h2_4 + h3*(10.0*h2_3 + h3*(10.0*h2_2 + h3*(5.0*h2 + h3)))) /) - Asys(1:6,6) = (/ -30.0*h1_4, -30.0*h2_4, & - -(6.0*h1_5 + h0*(15.0*h1_4 + h0*(20.0*h1_3 + h0*(15.0*h1_2 + h0*(6.0*h1 + h0))))), & - -h1_5, h2_5, & - (6.0*h2_5 + h3*(15.0*h2_4 + h3*(20.0*h2_3 + h3*(15.0*h2_2 + h3*(6.0*h2 + h3))))) /) - Bsys(1:6) = (/ 0.0, -2.0, 0.0, 0.0, 0.0, 0.0 /) - - call linear_solver( 6, Asys, Bsys, Csys ) - - alpha = Csys(1) - beta = Csys(2) - - tri_l(k+1) = alpha - tri_d(k+1) = 1.0 - tri_u(k+1) = beta - tri_b(k+1) = Csys(3) * u(k-1) + Csys(4) * u(k) + Csys(5) * u(k+1) + Csys(6) * u(k+2) - - enddo ! end loop on cells - - ! Use a right-biased stencil for the second row, as described in Eq. (53) of White and Adcroft (2009). - - ! Store temporary cell widths, avoiding singularities from zero thicknesses or extreme changes. - hMin = max(hNeglect, h_Min_Frac*((h(1) + h(2)) + (h(3) + h(4)))) - h0 = max(h(1), hMin) ; h1 = max(h(2), hMin) - h2 = max(h(3), hMin) ; h3 = max(h(4), hMin) - - ! Auxiliary calculations - h1_2 = h1 * h1 ; h1_3 = h1_2 * h1 ; h1_4 = h1_2 * h1_2 ; h1_5 = h1_3 * h1_2 - h2_2 = h2 * h2 ; h2_3 = h2_2 * h2 ; h2_4 = h2_2 * h2_2 ; h2_5 = h2_3 * h2_2 - h01 = h0 + h1 ; h01_2 = h01 * h01 - - ! Compute matrix entries - Asys(1:6,1) = (/ 0.0, 0.0, 1.0, 1.0, 1.0, 1.0 /) - Asys(1:6,2) = (/ 2.0, 2.0, (2.0*h1 + h0), h1, -h2, -(2.0*h2 + h3) /) - Asys(1:6,3) = (/ 6.0*h01, 0.0, (3.0*h1_2 + h0*(3.0*h1 + h0)), & - h1_2, h2_2, (3.0*h2_2 + h3*(3.0*h2 + h3)) /) - Asys(1:6,4) = (/ -12.0*h01_2, 0.0, -(4.0*h1_3 + h0*(6.0*h1_2 + h0*(4.0*h1 + h0))), & - -h1_3, h2_3, (4.0*h2_3 + h3*(6.0*h2_2 + h3*(4.0*h2 + h3))) /) - Asys(1:6,5) = (/ 20.0*(h01*h01_2), 0.0, (5.0*h1_4 + h0*(10.0*h1_3 + h0*(10.0*h1_2 + h0*(5.0*h1 + h0)))), & - h1_4, h2_4, (5.0*h2_4 + h3*(10.0*h2_3 + h3*(10.0*h2_2 + h3*(5.0*h2 + h3)))) /) - Asys(1:6,6) = (/ -30.0*(h01_2*h01_2), 0.0, & - -(6.0*h1_5 + h0*(15.0*h1_4 + h0*(20.0*h1_3 + h0*(15.0*h1_2 + h0*(6.0*h1 + h0))))), & - -h1_5, h2_5, & - (6.0*h2_5 + h3*(15.0*h2_4 + h3*(20.0*h2_3 + h3*(15.0*h2_2 + h3*(6.0*h2 + h3))))) /) - Bsys(1:6) = (/ 0.0, -2.0, -6.0*h1, 12.0*h1_2, -20.0*h1_3, 30.0*h1_4 /) - - call linear_solver( 6, Asys, Bsys, Csys ) - - alpha = Csys(1) - beta = Csys(2) - - tri_l(2) = alpha - tri_d(2) = 1.0 - tri_u(2) = beta - tri_b(2) = Csys(3) * u(1) + Csys(4) * u(2) + Csys(5) * u(3) + Csys(6) * u(4) - - ! Boundary conditions: left boundary - x(1) = 0.0 - do i = 1,6 - dx = h(i) - xavg = x(i) + 0.5 * dx - Asys(1:6,i) = (/ 1.0, xavg, (xavg**2 + C1_12*dx**2), xavg * (xavg**2 + 0.25*dx**2), & - (xavg**4 + 0.5*xavg**2*dx**2 + 0.0125*dx**4), & - xavg * (xavg**4 + C5_6*xavg**2*dx**2 + 0.0625*dx**4) /) - Bsys(i) = u(i) - x(i+1) = x(i) + dx - enddo - - call linear_solver( 6, Asys, Bsys, Csys ) - - Dsys(1) = Csys(2) - Dsys(2) = 2.0 * Csys(3) - Dsys(3) = 3.0 * Csys(4) - Dsys(4) = 4.0 * Csys(5) - Dsys(5) = 5.0 * Csys(6) - - tri_d(1) = 0.0 - tri_d(1) = 1.0 - tri_u(1) = 0.0 - tri_b(1) = Csys(2) ! evaluation_polynomial( Dsys, 5, x(1) ) ! first edge value - - ! Use a left-biased stencil for the second to last row, as described in Eq. (54) of White and Adcroft (2009). - - ! Store temporary cell widths, avoiding singularities from zero thicknesses or extreme changes. - hMin = max(hNeglect, h_Min_Frac*((h(N-3) + h(N-2)) + (h(N-1) + h(N)))) - h0 = max(h(N-3), hMin) ; h1 = max(h(N-2), hMin) - h2 = max(h(N-1), hMin) ; h3 = max(h(N), hMin) - - ! Auxiliary calculations - h1_2 = h1 * h1 ; h1_3 = h1_2 * h1 ; h1_4 = h1_2 * h1_2 ; h1_5 = h1_3 * h1_2 - h2_2 = h2 * h2 ; h2_3 = h2_2 * h2 ; h2_4 = h2_2 * h2_2 ; h2_5 = h2_3 * h2_2 - - h23 = h2 + h3 ; h23_2 = h23 * h23 - - ! Compute matrix entries - Asys(1:6,1) = (/ 0.0, 0.0, 1.0, 1.0, 1.0, 1.0 /) - Asys(1:6,2) = (/ 2.0, 2.0, (2.0*h1 + h0), h1, -h2, -(2.0*h2 + h3) /) - Asys(1:6,3) = (/ 0.0, -6.0*h23, (3.0*h1_2 + h0*(3.0*h1 + h0)), & - h1_2, h2_2, (3.0*h2_2 + h3*(3.0*h2 + h3)) /) - Asys(1:6,4) = (/ 0.0, -12.0*h23_2, -(4.0*h1_3 + h0*(6.0*h1_2 + h0*(4.0*h1 + h0))), & - -h1_3, h2_3, (4.0*h2_3 + h3*(6.0*h2_2 + h3*(4.0*h2 + h3))) /) - Asys(1:6,5) = (/ 0.0, -20.0*(h23*h23_2), (5.0*h1_4 + h0*(10.0*h1_3 + h0*(10.0*h1_2 + h0*(5.0*h1 + h0)))), & - h1_4, h2_4, (5.0*h2_4 + h3*(10.0*h2_3 + h3*(10.0*h2_2 + h3*(5.0*h2 + h3)))) /) - Asys(1:6,6) = (/ 0.0, -30.0*(h23_2*h23_2), & - -(6.0*h1_5 + h0*(15.0*h1_4 + h0*(20.0*h1_3 + h0*(15.0*h1_2 + h0*(6.0*h1 + h0))))), & - -h1_5, h2_5, & - (6.0*h2_5 + h3*(15.0*h2_4 + h3*(20.0*h2_3 + h3*(15.0*h2_2 + h3*(6.0*h2 + h3))))) /) - Bsys(1:6) = (/ 0.0, -2.0, 6.0*h2, 12.0*h2_2, 20.0*h2_3, 30.0*h2_4 /) - - call linear_solver( 6, Asys, Bsys, Csys ) - - alpha = Csys(1) - beta = Csys(2) - - tri_l(N) = alpha - tri_d(N) = 1.0 - tri_u(N) = beta - tri_b(N) = Csys(3) * u(N-3) + Csys(4) * u(N-2) + Csys(5) * u(N-1) + Csys(6) * u(N) - - ! Boundary conditions: right boundary - x(1) = 0.0 - do i = 1,6 - dx = h(N-6+i) - xavg = x(i) + 0.5*dx - Asys(1:6,i) = (/ 1.0, xavg, (xavg**2 + C1_12*dx**2), xavg * (xavg**2 + 0.25*dx**2), & - (xavg**4 + 0.5*xavg**2*dx**2 + 0.0125*dx**4), & - xavg * (xavg**4 + C5_6*xavg**2*dx**2 + 0.0625*dx**4) /) - Bsys(i) = u(N-6+i) - x(i+1) = x(i) + dx - enddo - - call linear_solver( 6, Asys, Bsys, Csys ) - - Dsys(1) = Csys(2) - Dsys(2) = 2.0 * Csys(3) - Dsys(3) = 3.0 * Csys(4) - Dsys(4) = 4.0 * Csys(5) - Dsys(5) = 5.0 * Csys(6) - - tri_l(N+1) = 0.0 - tri_d(N+1) = 1.0 - tri_u(N+1) = 0.0 - tri_b(N+1) = evaluation_polynomial( Dsys, 5, x(7) ) ! last edge value - - ! Solve tridiagonal system and assign edge values - call solve_tridiagonal_system( tri_l, tri_d, tri_u, tri_b, tri_x, N+1 ) - - do i = 2,N - edge_slopes(i,1) = tri_x(i) - edge_slopes(i-1,2) = tri_x(i) - enddo - edge_slopes(1,1) = tri_x(1) - edge_slopes(N,2) = tri_x(N+1) - -end subroutine edge_slopes_implicit_h5 - -end module regrid_edge_slopes diff --git a/src/ALE/regrid_edge_values.F90 b/src/ALE/regrid_edge_values.F90 index a4b788cd56..c32f1d28b5 100644 --- a/src/ALE/regrid_edge_values.F90 +++ b/src/ALE/regrid_edge_values.F90 @@ -5,7 +5,6 @@ module regrid_edge_values use MOM_error_handler, only : MOM_error, FATAL use regrid_solvers, only : solve_linear_system, solve_tridiagonal_system -use regrid_solvers, only : solve_diag_dominant_tridiag, linear_solver use polynomial_functions, only : evaluation_polynomial implicit none ; private @@ -13,13 +12,11 @@ module regrid_edge_values ! ----------------------------------------------------------------------------- ! The following routines are visible to the outside world ! ----------------------------------------------------------------------------- -public bound_edge_values -public average_discontinuous_edge_values -public check_discontinuous_edge_values -public edge_values_explicit_h2 -public edge_values_explicit_h4 -public edge_values_implicit_h4 -public edge_values_implicit_h6 +public bound_edge_values, average_discontinuous_edge_values, check_discontinuous_edge_values +public edge_values_explicit_h2, edge_values_explicit_h4 +public edge_values_implicit_h4, edge_values_implicit_h6 +public edge_slopes_implicit_h3, edge_slopes_implicit_h5 +! public solve_diag_dominant_tridiag, linear_solver ! The following parameters are used to avoid singular matrices for boundary ! extrapolation. The are needed only in the case where thicknesses vanish @@ -682,6 +679,469 @@ subroutine end_value_h4(dz, u, Csys) end subroutine end_value_h4 +!------------------------------------------------------------------------------ +!> Compute ih3 edge slopes (implicit third order accurate) +!! 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 +!! +!! Third-order implicit estimates of edge slopes are based on a two-cell +!! stencil. A tridiagonal system is set up and is based on expressing the +!! edge slopes in terms of neighboring cell averages. The generic +!! relationship is +!! +!! \f[ +!! \alpha u'_{i-1/2} + u'_{i+1/2} + \beta u'_{i+3/2} = +!! a \bar{u}_i + b \bar{u}_{i+1} +!! \f] +!! +!! and the stencil looks like this +!! +!! i i+1 +!! ..--o------o------o--.. +!! i-1/2 i+1/2 i+3/2 +!! +!! In this routine, the coefficients \f$\alpha\f$, \f$\beta\f$, a and b are computed, +!! the tridiagonal system is built, boundary conditions are prescribed and +!! the system is solved to yield edge-slope estimates. +!! +!! There are N+1 unknowns and we are able to write N-1 equations. The +!! boundary conditions close the system. +subroutine edge_slopes_implicit_h3( N, h, u, edge_slopes, h_neglect, answers_2018 ) + integer, intent(in) :: N !< Number of cells + real, dimension(N), intent(in) :: h !< cell widths [H] + real, dimension(N), intent(in) :: u !< cell average properties in arbitrary units [A] + real, dimension(N,2), intent(inout) :: edge_slopes !< Returned edge slopes [A H-1]; the + !! second index is for the two edges of each cell. + real, optional, intent(in) :: h_neglect !< A negligibly small width [H] + logical, optional, intent(in) :: answers_2018 !< If true use older, less acccurate expressions. + ! Local variables + integer :: i, j ! loop indexes + real :: h0, h1 ! cell widths [H or nondim] + real :: h0_2, h1_2, h0h1 ! products of cell widths [H2 or nondim] + real :: h0_3, h1_3 ! products of three cell widths [H3 or nondim] + real :: h_min ! A minimal cell width [H] + real :: d ! A temporary variable [H3] + real :: I_d ! A temporary variable [nondim] + real :: I_h ! Inverses of thicknesses [H-1] + real :: alpha, beta ! stencil coefficients [nondim] + real :: a, b ! weights of cells [H-1] + real, parameter :: C1_12 = 1.0 / 12.0 + real, dimension(5) :: x ! Coordinate system with 0 at edges [H] + real :: dx, xavg ! Differences and averages of successive values of x [H] + real, dimension(4,4) :: Asys ! matrix used to find boundary conditions + real, dimension(4) :: Bsys, Csys + real, dimension(3) :: Dsys + real, dimension(N+1) :: tri_l, & ! tridiagonal system (lower diagonal) [nondim] + tri_d, & ! tridiagonal system (middle diagonal) [nondim] + tri_c, & ! tridiagonal system central value, with tri_d = tri_c+tri_l+tri_u + tri_u, & ! tridiagonal system (upper diagonal) [nondim] + tri_b, & ! tridiagonal system (right hand side) [A H-1] + tri_x ! tridiagonal system (solution vector) [A H-1] + real :: hNeglect ! A negligible thickness [H]. + real :: hNeglect3 ! hNeglect^3 [H3]. + logical :: use_2018_answers ! If true use older, less acccurate expressions. + + hNeglect = hNeglect_dflt ; if (present(h_neglect)) hNeglect = h_neglect + hNeglect3 = hNeglect**3 + use_2018_answers = .true. ; if (present(answers_2018)) use_2018_answers = answers_2018 + + ! Loop on cells (except last one) + do i = 1,N-1 + + if (use_2018_answers) then + ! Get cell widths + h0 = h(i) + h1 = h(i+1) + + ! Auxiliary calculations + h0h1 = h0 * h1 + h0_2 = h0 * h0 + h1_2 = h1 * h1 + h0_3 = h0_2 * h0 + h1_3 = h1_2 * h1 + + d = 4.0 * h0h1 * ( h0 + h1 ) + h1_3 + h0_3 + + ! Coefficients + alpha = h1 * (h0_2 + h0h1 - h1_2) / ( d + hNeglect3 ) + beta = h0 * (h1_2 + h0h1 - h0_2) / ( d + hNeglect3 ) + a = -12.0 * h0h1 / ( d + hNeglect3 ) + b = -a + + tri_l(i+1) = alpha + tri_d(i+1) = 1.0 + tri_u(i+1) = beta + + tri_b(i+1) = a * u(i) + b * u(i+1) + else + ! Get cell widths + h0 = max(h(i), hNeglect) + h1 = max(h(i+1), hNeglect) + + I_h = 1.0 / (h0 + h1) + h0 = h0 * I_h ; h1 = h1 * I_h + + h0h1 = h0 * h1 ; h0_2 = h0 * h0 ; h1_2 = h1 * h1 + h0_3 = h0_2 * h0 ; h1_3 = h1_2 * h1 + + I_d = 1.0 / (4.0 * h0h1 * ( h0 + h1 ) + h1_3 + h0_3) ! = 1 / ((h0 + h1)**3 + h0*h1*(h0 + h1)) + + ! Set the tridiagonal coefficients + tri_l(i+1) = (h1 * ((h0_2 + h0h1) - h1_2)) * I_d + ! tri_d(i+1) = 1.0 + tri_c(i+1) = 2.0 * ((h0_2 + h1_2) * (h0 + h1)) * I_d + tri_u(i+1) = (h0 * ((h1_2 + h0h1) - h0_2)) * I_d + ! The following expressions have been simplified using the nondimensionalization above: + ! I_d = 1.0 / (1.0 + h0h1) + ! tri_l(i+1) = (h0h1 - h1_3) * I_d + ! tri_c(i+1) = 2.0 * (h0_2 + h1_2) * I_d + ! tri_u(i+1) = (h0h1 - h0_3) * I_d + + tri_b(i+1) = 12.0 * (h0h1 * I_d) * ((u(i+1) - u(i)) * I_h) + endif + + enddo ! end loop on cells + + ! Boundary conditions: set the first edge slope + if (use_2018_answers) then + x(1) = 0.0 + do i = 1,4 + dx = h(i) + x(i+1) = x(i) + dx + do j = 1,4 ; Asys(i,j) = ( (x(i+1)**j) - (x(i)**j) ) / j ; enddo + Bsys(i) = u(i) * dx + enddo + + call solve_linear_system( Asys, Bsys, Csys, 4 ) + + Dsys(1) = Csys(2) ; Dsys(2) = 2.0 * Csys(3) ; Dsys(3) = 3.0 * Csys(4) + tri_b(1) = evaluation_polynomial( Dsys, 3, x(1) ) ! Set the first edge slope + tri_d(1) = 1.0 + else ! Use expressions with less sensitivity to roundoff + h_min = max( hNeglect, hMinFrac * ((h(1) + h(2)) + (h(3) + h(4))) ) + x(1) = 0.0 + do i = 1,4 + dx = max(h_min, h(i) ) + x(i+1) = x(i) + dx + xavg = x(i) + 0.5*dx + Asys(1:4,i) = (/ 1.0, xavg, (xavg**2 + C1_12*dx**2), xavg * (xavg**2 + 0.25*dx**2) /) + Bsys(i) = u(i) + enddo + + call linear_solver( 4, Asys, Bsys, Csys ) + + ! Set the first edge slope + tri_b(1) = Csys(2) ! + x(1)*(2.0*Csys(3) + x(1)*(3.0*Csys(4))) + tri_c(1) = 1.0 + endif + tri_u(1) = 0.0 ! tri_l(1) = 0.0 + + ! Boundary conditions: set the last edge slope + if (use_2018_answers) then + x(1) = 0.0 + do i = 1,4 + dx = h(N-4+i) + x(i+1) = x(i) + dx + do j = 1,4 ; Asys(i,j) = ( (x(i+1)**j) - (x(i)**j) ) / j ; enddo + Bsys(i) = u(N-4+i) * dx + enddo + + call solve_linear_system( Asys, Bsys, Csys, 4 ) + + Dsys(1) = Csys(2) ; Dsys(2) = 2.0 * Csys(3) ; Dsys(3) = 3.0 * Csys(4) + ! Set the last edge slope + tri_b(N+1) = evaluation_polynomial( Dsys, 3, x(5) ) + tri_d(N+1) = 1.0 + else + ! Use expressions with less sensitivity to roundoff, including using a coordinate + ! system that sets the origin at the last interface in the domain. + h_min = max( hNeglect, hMinFrac * ((h(N-3) + h(N-2)) + (h(N-1) + h(N))) ) + x(1) = 0.0 + do i = 1,4 + dx = max(h_min, h(N+1-i) ) + x(i+1) = x(i) + dx + xavg = x(i) + 0.5*dx + Asys(1:4,i) = (/ 1.0, xavg, (xavg**2 + C1_12*dx**2), xavg * (xavg**2 + 0.25*dx**2) /) + Bsys(i) = u(N+1-i) + enddo + + call linear_solver( 4, Asys, Bsys, Csys ) + + ! Set the last edge slope + tri_b(N+1) = Csys(2) + tri_c(N+1) = 1.0 + endif + tri_l(N+1) = 0.0 ! tri_u(N+1) = 0.0 + + ! Solve tridiagonal system and assign edge slopes + if (use_2018_answers) then + call solve_tridiagonal_system( tri_l, tri_d, tri_u, tri_b, tri_x, N+1 ) + else + call solve_diag_dominant_tridiag( tri_l, tri_c, tri_u, tri_b, tri_x, N+1 ) + endif + + do i = 2,N + edge_slopes(i,1) = tri_x(i) + edge_slopes(i-1,2) = tri_x(i) + enddo + edge_slopes(1,1) = tri_x(1) + edge_slopes(N,2) = tri_x(N+1) + +end subroutine edge_slopes_implicit_h3 + + +!------------------------------------------------------------------------------ +!> Compute ih5 edge slopes (implicit fifth order accurate) +subroutine edge_slopes_implicit_h5( N, h, u, edge_slopes, h_neglect, answers_2018 ) + integer, intent(in) :: N !< Number of cells + real, dimension(N), intent(in) :: h !< cell widths [H] + real, dimension(N), intent(in) :: u !< cell average properties in arbitrary units [A] + real, dimension(N,2), intent(inout) :: edge_slopes !< Returned edge slopes [A H-1]; the + !! second index is for the two edges of each cell. + real, optional, intent(in) :: h_neglect !< A negligibly small width [H] + logical, optional, intent(in) :: answers_2018 !< If true use older, less acccurate expressions. +! ----------------------------------------------------------------------------- +! Fifth-order implicit estimates of edge slopes are based on a four-cell, +! three-edge stencil. A tridiagonal system is set up and is based on +! expressing the edge slopes in terms of neighboring cell averages. +! +! The generic relationship is +! +! \alpha u'_{i-1/2} + u'_{i+1/2} + \beta u'_{i+3/2} = +! a \bar{u}_{i-1} + b \bar{u}_i + c \bar{u}_{i+1} + d \bar{u}_{i+2} +! +! and the stencil looks like this +! +! i-1 i i+1 i+2 +! ..--o------o------o------o------o--.. +! i-1/2 i+1/2 i+3/2 +! +! In this routine, the coefficients \alpha, \beta, a, b, c and d are +! computed, the tridiagonal system is built, boundary conditions are +! prescribed and the system is solved to yield edge-value estimates. +! +! Note that the centered stencil only applies to edges 3 to N-1 (edges are +! numbered 1 to n+1), which yields N-3 equations for N+1 unknowns. Two other +! equations are written by using a right-biased stencil for edge 2 and a +! left-biased stencil for edge N. The prescription of boundary conditions +! (using sixth-order polynomials) closes the system. +! +! CAUTION: For each edge, in order to determine the coefficients of the +! implicit expression, a 6x6 linear system is solved. This may +! become computationally expensive if regridding is carried out +! often. Figuring out closed-form expressions for these coefficients +! on nonuniform meshes turned out to be intractable. +! ----------------------------------------------------------------------------- + + ! Local variables + real :: h0, h1, h2, h3 ! cell widths [H] + real :: hMin ! The minimum thickness used in these calculations [H] + real :: h01, h01_2 ! Summed thicknesses to various powers [H^n ~> m^n or kg^n m-2n] + real :: h23, h23_2 ! Summed thicknesses to various powers [H^n ~> m^n or kg^n m-2n] + real :: hNeglect ! A negligible thickness [H]. + real :: h1_2, h2_2 ! the coefficients of the + real :: h1_3, h2_3 ! tridiagonal system + real :: h1_4, h2_4 ! ... + real :: h1_5, h2_5 ! ... + real :: alpha, beta ! stencil coefficients + real, dimension(7) :: x ! Coordinate system with 0 at edges [same units as h] + real, parameter :: C1_12 = 1.0 / 12.0 + real, parameter :: C5_6 = 5.0 / 6.0 + real :: dx, xavg ! Differences and averages of successive values of x [same units as h] + real, dimension(6,6) :: Asys ! matrix used to find boundary conditions + real, dimension(6) :: Bsys, Csys ! ... + real, dimension(5) :: Dsys ! derivative + real, dimension(N+1) :: tri_l, & ! trid. system (lower diagonal) + tri_d, & ! trid. system (middle diagonal) + tri_u, & ! trid. system (upper diagonal) + tri_b, & ! trid. system (unknowns vector) + tri_x ! trid. system (rhs) + real :: h_Min_Frac = 1.0e-4 + integer :: i, j, k ! loop indexes + + hNeglect = hNeglect_dflt ; if (present(h_neglect)) hNeglect = h_neglect + + ! Loop on cells (except the first and last ones) + do k = 2,N-2 + ! Store temporary cell widths, avoiding singularities from zero thicknesses or extreme changes. + hMin = max(hNeglect, h_Min_Frac*((h(k-1) + h(k)) + (h(k+1) + h(k+2)))) + h0 = max(h(k-1), hMin) ; h1 = max(h(k), hMin) + h2 = max(h(k+1), hMin) ; h3 = max(h(k+2), hMin) + + ! Auxiliary calculations + h1_2 = h1 * h1 ; h1_3 = h1_2 * h1 ; h1_4 = h1_2 * h1_2 ; h1_5 = h1_3 * h1_2 + h2_2 = h2 * h2 ; h2_3 = h2_2 * h2 ; h2_4 = h2_2 * h2_2 ; h2_5 = h2_3 * h2_2 + + ! Compute matrix entries as described in Eq. (52) of White and Adcroft (2009). The last 4 rows are + ! Asys(1:6,n) = (/ -n*(n-1)*(-h1)**(n-2), -n*(n-1)*h1**(n-2), (-1)**(n-1) * ((h0+h1)**n - h0**n) / h0, & + ! (-h1)**(n-1), h2**(n-1), ((h2+h3)**n - h2**n) / h3 /) + + Asys(1:6,1) = (/ 0.0, 0.0, 1.0, 1.0, 1.0, 1.0 /) + Asys(1:6,2) = (/ 2.0, 2.0, (2.0*h1 + h0), h1, -h2, -(2.0*h2 + h3) /) + Asys(1:6,3) = (/ 6.0*h1, -6.0* h2, (3.0*h1_2 + h0*(3.0*h1 + h0)), & + h1_2, h2_2, (3.0*h2_2 + h3*(3.0*h2 + h3)) /) + Asys(1:6,4) = (/ -12.0*h1_2, -12.0*h2_2, -(4.0*h1_3 + h0*(6.0*h1_2 + h0*(4.0*h1 + h0))), & + -h1_3, h2_3, (4.0*h2_3 + h3*(6.0*h2_2 + h3*(4.0*h2 + h3))) /) + Asys(1:6,5) = (/ 20.0*h1_3, -20.0*h2_3, (5.0*h1_4 + h0*(10.0*h1_3 + h0*(10.0*h1_2 + h0*(5.0*h1 + h0)))), & + h1_4, h2_4, (5.0*h2_4 + h3*(10.0*h2_3 + h3*(10.0*h2_2 + h3*(5.0*h2 + h3)))) /) + Asys(1:6,6) = (/ -30.0*h1_4, -30.0*h2_4, & + -(6.0*h1_5 + h0*(15.0*h1_4 + h0*(20.0*h1_3 + h0*(15.0*h1_2 + h0*(6.0*h1 + h0))))), & + -h1_5, h2_5, & + (6.0*h2_5 + h3*(15.0*h2_4 + h3*(20.0*h2_3 + h3*(15.0*h2_2 + h3*(6.0*h2 + h3))))) /) + Bsys(1:6) = (/ 0.0, -2.0, 0.0, 0.0, 0.0, 0.0 /) + + call linear_solver( 6, Asys, Bsys, Csys ) + + alpha = Csys(1) + beta = Csys(2) + + tri_l(k+1) = alpha + tri_d(k+1) = 1.0 + tri_u(k+1) = beta + tri_b(k+1) = Csys(3) * u(k-1) + Csys(4) * u(k) + Csys(5) * u(k+1) + Csys(6) * u(k+2) + + enddo ! end loop on cells + + ! Use a right-biased stencil for the second row, as described in Eq. (53) of White and Adcroft (2009). + + ! Store temporary cell widths, avoiding singularities from zero thicknesses or extreme changes. + hMin = max(hNeglect, h_Min_Frac*((h(1) + h(2)) + (h(3) + h(4)))) + h0 = max(h(1), hMin) ; h1 = max(h(2), hMin) + h2 = max(h(3), hMin) ; h3 = max(h(4), hMin) + + ! Auxiliary calculations + h1_2 = h1 * h1 ; h1_3 = h1_2 * h1 ; h1_4 = h1_2 * h1_2 ; h1_5 = h1_3 * h1_2 + h2_2 = h2 * h2 ; h2_3 = h2_2 * h2 ; h2_4 = h2_2 * h2_2 ; h2_5 = h2_3 * h2_2 + h01 = h0 + h1 ; h01_2 = h01 * h01 + + ! Compute matrix entries + Asys(1:6,1) = (/ 0.0, 0.0, 1.0, 1.0, 1.0, 1.0 /) + Asys(1:6,2) = (/ 2.0, 2.0, (2.0*h1 + h0), h1, -h2, -(2.0*h2 + h3) /) + Asys(1:6,3) = (/ 6.0*h01, 0.0, (3.0*h1_2 + h0*(3.0*h1 + h0)), & + h1_2, h2_2, (3.0*h2_2 + h3*(3.0*h2 + h3)) /) + Asys(1:6,4) = (/ -12.0*h01_2, 0.0, -(4.0*h1_3 + h0*(6.0*h1_2 + h0*(4.0*h1 + h0))), & + -h1_3, h2_3, (4.0*h2_3 + h3*(6.0*h2_2 + h3*(4.0*h2 + h3))) /) + Asys(1:6,5) = (/ 20.0*(h01*h01_2), 0.0, (5.0*h1_4 + h0*(10.0*h1_3 + h0*(10.0*h1_2 + h0*(5.0*h1 + h0)))), & + h1_4, h2_4, (5.0*h2_4 + h3*(10.0*h2_3 + h3*(10.0*h2_2 + h3*(5.0*h2 + h3)))) /) + Asys(1:6,6) = (/ -30.0*(h01_2*h01_2), 0.0, & + -(6.0*h1_5 + h0*(15.0*h1_4 + h0*(20.0*h1_3 + h0*(15.0*h1_2 + h0*(6.0*h1 + h0))))), & + -h1_5, h2_5, & + (6.0*h2_5 + h3*(15.0*h2_4 + h3*(20.0*h2_3 + h3*(15.0*h2_2 + h3*(6.0*h2 + h3))))) /) + Bsys(1:6) = (/ 0.0, -2.0, -6.0*h1, 12.0*h1_2, -20.0*h1_3, 30.0*h1_4 /) + + call linear_solver( 6, Asys, Bsys, Csys ) + + alpha = Csys(1) + beta = Csys(2) + + tri_l(2) = alpha + tri_d(2) = 1.0 + tri_u(2) = beta + tri_b(2) = Csys(3) * u(1) + Csys(4) * u(2) + Csys(5) * u(3) + Csys(6) * u(4) + + ! Boundary conditions: left boundary + x(1) = 0.0 + do i = 1,6 + dx = h(i) + xavg = x(i) + 0.5 * dx + Asys(1:6,i) = (/ 1.0, xavg, (xavg**2 + C1_12*dx**2), xavg * (xavg**2 + 0.25*dx**2), & + (xavg**4 + 0.5*xavg**2*dx**2 + 0.0125*dx**4), & + xavg * (xavg**4 + C5_6*xavg**2*dx**2 + 0.0625*dx**4) /) + Bsys(i) = u(i) + x(i+1) = x(i) + dx + enddo + + call linear_solver( 6, Asys, Bsys, Csys ) + + Dsys(1) = Csys(2) + Dsys(2) = 2.0 * Csys(3) + Dsys(3) = 3.0 * Csys(4) + Dsys(4) = 4.0 * Csys(5) + Dsys(5) = 5.0 * Csys(6) + + tri_d(1) = 0.0 + tri_d(1) = 1.0 + tri_u(1) = 0.0 + tri_b(1) = Csys(2) ! evaluation_polynomial( Dsys, 5, x(1) ) ! first edge value + + ! Use a left-biased stencil for the second to last row, as described in Eq. (54) of White and Adcroft (2009). + + ! Store temporary cell widths, avoiding singularities from zero thicknesses or extreme changes. + hMin = max(hNeglect, h_Min_Frac*((h(N-3) + h(N-2)) + (h(N-1) + h(N)))) + h0 = max(h(N-3), hMin) ; h1 = max(h(N-2), hMin) + h2 = max(h(N-1), hMin) ; h3 = max(h(N), hMin) + + ! Auxiliary calculations + h1_2 = h1 * h1 ; h1_3 = h1_2 * h1 ; h1_4 = h1_2 * h1_2 ; h1_5 = h1_3 * h1_2 + h2_2 = h2 * h2 ; h2_3 = h2_2 * h2 ; h2_4 = h2_2 * h2_2 ; h2_5 = h2_3 * h2_2 + + h23 = h2 + h3 ; h23_2 = h23 * h23 + + ! Compute matrix entries + Asys(1:6,1) = (/ 0.0, 0.0, 1.0, 1.0, 1.0, 1.0 /) + Asys(1:6,2) = (/ 2.0, 2.0, (2.0*h1 + h0), h1, -h2, -(2.0*h2 + h3) /) + Asys(1:6,3) = (/ 0.0, -6.0*h23, (3.0*h1_2 + h0*(3.0*h1 + h0)), & + h1_2, h2_2, (3.0*h2_2 + h3*(3.0*h2 + h3)) /) + Asys(1:6,4) = (/ 0.0, -12.0*h23_2, -(4.0*h1_3 + h0*(6.0*h1_2 + h0*(4.0*h1 + h0))), & + -h1_3, h2_3, (4.0*h2_3 + h3*(6.0*h2_2 + h3*(4.0*h2 + h3))) /) + Asys(1:6,5) = (/ 0.0, -20.0*(h23*h23_2), (5.0*h1_4 + h0*(10.0*h1_3 + h0*(10.0*h1_2 + h0*(5.0*h1 + h0)))), & + h1_4, h2_4, (5.0*h2_4 + h3*(10.0*h2_3 + h3*(10.0*h2_2 + h3*(5.0*h2 + h3)))) /) + Asys(1:6,6) = (/ 0.0, -30.0*(h23_2*h23_2), & + -(6.0*h1_5 + h0*(15.0*h1_4 + h0*(20.0*h1_3 + h0*(15.0*h1_2 + h0*(6.0*h1 + h0))))), & + -h1_5, h2_5, & + (6.0*h2_5 + h3*(15.0*h2_4 + h3*(20.0*h2_3 + h3*(15.0*h2_2 + h3*(6.0*h2 + h3))))) /) + Bsys(1:6) = (/ 0.0, -2.0, 6.0*h2, 12.0*h2_2, 20.0*h2_3, 30.0*h2_4 /) + + call linear_solver( 6, Asys, Bsys, Csys ) + + alpha = Csys(1) + beta = Csys(2) + + tri_l(N) = alpha + tri_d(N) = 1.0 + tri_u(N) = beta + tri_b(N) = Csys(3) * u(N-3) + Csys(4) * u(N-2) + Csys(5) * u(N-1) + Csys(6) * u(N) + + ! Boundary conditions: right boundary + x(1) = 0.0 + do i = 1,6 + dx = h(N-6+i) + xavg = x(i) + 0.5*dx + Asys(1:6,i) = (/ 1.0, xavg, (xavg**2 + C1_12*dx**2), xavg * (xavg**2 + 0.25*dx**2), & + (xavg**4 + 0.5*xavg**2*dx**2 + 0.0125*dx**4), & + xavg * (xavg**4 + C5_6*xavg**2*dx**2 + 0.0625*dx**4) /) + Bsys(i) = u(N-6+i) + x(i+1) = x(i) + dx + enddo + + call linear_solver( 6, Asys, Bsys, Csys ) + + Dsys(1) = Csys(2) + Dsys(2) = 2.0 * Csys(3) + Dsys(3) = 3.0 * Csys(4) + Dsys(4) = 4.0 * Csys(5) + Dsys(5) = 5.0 * Csys(6) + + tri_l(N+1) = 0.0 + tri_d(N+1) = 1.0 + tri_u(N+1) = 0.0 + tri_b(N+1) = evaluation_polynomial( Dsys, 5, x(7) ) ! last edge value + + ! Solve tridiagonal system and assign edge values + call solve_tridiagonal_system( tri_l, tri_d, tri_u, tri_b, tri_x, N+1 ) + + do i = 2,N + edge_slopes(i,1) = tri_x(i) + edge_slopes(i-1,2) = tri_x(i) + enddo + edge_slopes(1,1) = tri_x(1) + edge_slopes(N,2) = tri_x(N+1) + +end subroutine edge_slopes_implicit_h5 + + !> Compute ih6 edge values (implicit sixth order accurate) in the same units as u. !! !! Sixth-order implicit estimates of edge values are based on a four-cell, @@ -915,6 +1375,115 @@ subroutine edge_values_implicit_h6( N, h, u, edge_val, h_neglect, answers_2018 ) end subroutine edge_values_implicit_h6 +!> Solve the tridiagonal system AX = R +!! +!! This routine uses a variant of Thomas's algorithm to solve the tridiagonal system AX = R, in +!! a form that is guaranteed to avoid dividing by a zero pivot. The matrix A is made up of +!! lower (Al) and upper diagonals (Au) and a central diagonal Ad = Ac+Al+Au, where +!! Al, Au, and Ac are all positive (or negative) definite. However when Ac is smaller than +!! roundoff compared with (Al+Au), the answers are prone to inaccuracy. +subroutine solve_diag_dominant_tridiag( Al, Ac, Au, R, X, N ) + integer, intent(in) :: N !< The size of the system + real, dimension(N), intent(in) :: Ac !< Matrix center diagonal offset from Al + Au + real, dimension(N), intent(in) :: Al !< Matrix lower diagonal + real, dimension(N), intent(in) :: Au !< Matrix upper diagonal + real, dimension(N), intent(in) :: R !< system right-hand side + real, dimension(N), intent(out) :: X !< solution vector + ! Local variables + real, dimension(N) :: c1 ! Au / pivot for the backward sweep + real :: d1 ! The next value of 1.0 - c1 + real :: I_pivot ! The inverse of the most recent pivot + real :: denom_t1 ! The first term in the denominator of the inverse of the pivot. + integer :: k ! Loop index + + ! Factorization and forward sweep, in a form that will never give a division by a + ! zero pivot for positive definite Ac, Al, and Au. + I_pivot = 1.0 / (Ac(1) + Au(1)) + d1 = Ac(1) * I_pivot + c1(1) = Au(1) * I_pivot + X(1) = R(1) * I_pivot + do k=2,N-1 + denom_t1 = Ac(k) + d1 * Al(k) + I_pivot = 1.0 / (denom_t1 + Au(k)) + d1 = denom_t1 * I_pivot + c1(k) = Au(k) * I_pivot + X(k) = (R(k) - Al(k) * X(k-1)) * I_pivot + enddo + I_pivot = 1.0 / (Ac(N) + d1 * Al(N)) + X(N) = (R(N) - Al(N) * X(N-1)) * I_pivot + ! Backward sweep + do k=N-1,1,-1 + X(k) = X(k) - c1(k) * X(k+1) + enddo + +end subroutine solve_diag_dominant_tridiag + + +!> Solve the linear system AX = R by Gaussian elimination +!! +!! This routine uses Gauss's algorithm to transform the system's original +!! matrix into an upper triangular matrix. Back substitution then yields the answer. +!! The matrix A must be square, with the first index varing along the row. +subroutine linear_solver( N, A, R, X ) + integer, intent(in) :: N !< The size of the system + real, dimension(N,N), intent(inout) :: A !< The matrix being inverted [nondim] + real, dimension(N), intent(inout) :: R !< system right-hand side [A] + real, dimension(N), intent(inout) :: X !< solution vector [A] + + ! Local variables + real :: factor ! The factor that eliminates the leading nonzero element in a row. + real :: I_pivot ! The reciprocal of the pivot value [inverse of the input units of a row of A] + real :: swap + integer :: i, j, k + + ! Loop on rows to transform the problem into multiplication by an upper-right matrix. + do i=1,N-1 + ! Seek a pivot for column i starting in row i, and continuing into the remaining rows. If the + ! pivot is in a row other than i, swap them. If no valid pivot is found, i = N+1 after this loop. + do k=i,N ; if ( abs(A(i,k)) > 0.0 ) exit ; enddo ! end loop to find pivot + if ( k > N ) then ! No pivot could be found and the system is singular. + write(0,*) ' A=',A + call MOM_error( FATAL, 'The linear system sent to linear_solver is singular.' ) + endif + + ! If the pivot is in a row that is different than row i, swap those two rows, noting that both + ! rows start with i-1 zero values. + if ( k /= i ) then + do j=i,N ; swap = A(j,i) ; A(j,i) = A(j,k) ; A(j,k) = swap ; enddo + swap = R(i) ; R(i) = R(k) ; R(k) = swap + endif + + ! Transform the pivot to 1 by dividing the entire row (right-hand side included) by the pivot + I_pivot = 1.0 / A(i,i) + A(i,i) = 1.0 + do j=i+1,N ; A(j,i) = A(j,i) * I_pivot ; enddo + R(i) = R(i) * I_pivot + + ! Put zeros in column for all rows below that contain the pivot (which is row i) + do k=i+1,N ! k is the row index + factor = A(i,k) + ! A(i,k) = 0.0 ! These elements are not used again, so this line can be skipped for speed. + do j=i+1,N ; A(j,k) = A(j,k) - factor * A(j,i) ; enddo + R(k) = R(k) - factor * R(i) + enddo + + enddo ! end loop on i + + ! Solve the system by back substituting into what is now an upper-right matrix. + if (A(N,N) == 0.0) then ! No pivot could be found and the system is singular. + ! write(0,*) ' A=',A + call MOM_error( FATAL, 'The final pivot in linear_solver is zero.' ) + endif + X(N) = R(N) / A(N,N) ! The last row can now be solved trivially. + do i=N-1,1,-1 ! loop on rows, starting from second to last row + X(i) = R(i) + do j=i+1,N ; X(i) = X(i) - A(j,i) * X(j) ; enddo + enddo + +end subroutine linear_solver + + + ! Verify that A*C = R to within roundoff. subroutine test_line(msg, N, A, C, R, mag, tolerance) integer, intent(in) :: N diff --git a/src/ALE/regrid_interp.F90 b/src/ALE/regrid_interp.F90 index 7b6bfd0e92..3faa5f46b1 100644 --- a/src/ALE/regrid_interp.F90 +++ b/src/ALE/regrid_interp.F90 @@ -8,7 +8,7 @@ module regrid_interp use regrid_edge_values, only : edge_values_explicit_h2, edge_values_explicit_h4 use regrid_edge_values, only : edge_values_implicit_h4, edge_values_implicit_h6 -use regrid_edge_slopes, only : edge_slopes_implicit_h3, edge_slopes_implicit_h5 +use regrid_edge_values, only : edge_slopes_implicit_h3, edge_slopes_implicit_h5 use PLM_functions, only : PLM_reconstruction, PLM_boundary_extrapolation use PPM_functions, only : PPM_reconstruction, PPM_boundary_extrapolation From 981e3cb4b17649a07d81121daf25cef3c948e8ce Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 15 Jan 2020 18:38:46 -0500 Subject: [PATCH 028/316] (*)Corrected a sign error in edge_slopes_implicit_h3 Corrected a recently introduced sign error in the right end slope estimate of edge_slopes_implicit_h3 when REMAPPING_2018_ANSWERS is false. Also used a coordinate system that starts at the right edge for edge_values_implicit_h6 and edge_slopes_implicit_h5. This will change answers when REMAPPING_2018_ANSWERS is false and INTERPOLATION_SCHEME = "P3M_IH4IH3" or "PQM_IH4IH3" or REMAPPING_SCHEME = "PQM_IH4IH3", while answers are mathematically equivalent but change at roundoff when INTERPOLATION_SCHEME = "P3M_IH46H5" or "PQM_IH6IH5" or REMAPPING_SCHEME = "PQM_IH6IH5". Because these settings are not yet used in the MOM6-examples test cases, no answers are changed in the regression tests. --- src/ALE/regrid_edge_values.F90 | 31 ++++++++++--------------------- 1 file changed, 10 insertions(+), 21 deletions(-) diff --git a/src/ALE/regrid_edge_values.F90 b/src/ALE/regrid_edge_values.F90 index c32f1d28b5..ea4f3a10fb 100644 --- a/src/ALE/regrid_edge_values.F90 +++ b/src/ALE/regrid_edge_values.F90 @@ -833,7 +833,7 @@ subroutine edge_slopes_implicit_h3( N, h, u, edge_slopes, h_neglect, answers_201 call linear_solver( 4, Asys, Bsys, Csys ) ! Set the first edge slope - tri_b(1) = Csys(2) ! + x(1)*(2.0*Csys(3) + x(1)*(3.0*Csys(4))) + tri_b(1) = Csys(2) tri_c(1) = 1.0 endif tri_u(1) = 0.0 ! tri_l(1) = 0.0 @@ -870,7 +870,8 @@ subroutine edge_slopes_implicit_h3( N, h, u, edge_slopes, h_neglect, answers_201 call linear_solver( 4, Asys, Bsys, Csys ) ! Set the last edge slope - tri_b(N+1) = Csys(2) + + tri_b(N+1) = -Csys(2) tri_c(N+1) = 1.0 endif tri_l(N+1) = 0.0 ! tri_u(N+1) = 0.0 @@ -1055,16 +1056,10 @@ subroutine edge_slopes_implicit_h5( N, h, u, edge_slopes, h_neglect, answers_201 call linear_solver( 6, Asys, Bsys, Csys ) - Dsys(1) = Csys(2) - Dsys(2) = 2.0 * Csys(3) - Dsys(3) = 3.0 * Csys(4) - Dsys(4) = 4.0 * Csys(5) - Dsys(5) = 5.0 * Csys(6) - tri_d(1) = 0.0 tri_d(1) = 1.0 tri_u(1) = 0.0 - tri_b(1) = Csys(2) ! evaluation_polynomial( Dsys, 5, x(1) ) ! first edge value + tri_b(1) = Csys(2) ! first edge value ! Use a left-biased stencil for the second to last row, as described in Eq. (54) of White and Adcroft (2009). @@ -1107,27 +1102,21 @@ subroutine edge_slopes_implicit_h5( N, h, u, edge_slopes, h_neglect, answers_201 ! Boundary conditions: right boundary x(1) = 0.0 do i = 1,6 - dx = h(N-6+i) + dx = h(N+1-i) xavg = x(i) + 0.5*dx Asys(1:6,i) = (/ 1.0, xavg, (xavg**2 + C1_12*dx**2), xavg * (xavg**2 + 0.25*dx**2), & (xavg**4 + 0.5*xavg**2*dx**2 + 0.0125*dx**4), & xavg * (xavg**4 + C5_6*xavg**2*dx**2 + 0.0625*dx**4) /) - Bsys(i) = u(N-6+i) + Bsys(i) = u(N+1-i) x(i+1) = x(i) + dx enddo call linear_solver( 6, Asys, Bsys, Csys ) - Dsys(1) = Csys(2) - Dsys(2) = 2.0 * Csys(3) - Dsys(3) = 3.0 * Csys(4) - Dsys(4) = 4.0 * Csys(5) - Dsys(5) = 5.0 * Csys(6) - tri_l(N+1) = 0.0 tri_d(N+1) = 1.0 tri_u(N+1) = 0.0 - tri_b(N+1) = evaluation_polynomial( Dsys, 5, x(7) ) ! last edge value + tri_b(N+1) = -Csys(2) ! Solve tridiagonal system and assign edge values call solve_tridiagonal_system( tri_l, tri_d, tri_u, tri_b, tri_x, N+1 ) @@ -1346,12 +1335,12 @@ subroutine edge_values_implicit_h6( N, h, u, edge_val, h_neglect, answers_2018 ) hMin = max( hNeglect, hMinFrac*(h(N-3) + h(N-2)) + ((h(N-1) + h(N)) + (h(N-5) + h(N-4))) ) x(1) = 0.0 do i = 1,6 - dx = max( hMin, h(N-6+i) ) + dx = max( hMin, h(N+1-i) ) xavg = x(i) + 0.5 * dx Asys(1:6,i) = (/ 1.0, xavg, (xavg**2 + C1_12*dx**2), xavg * (xavg**2 + 0.25*dx**2), & (xavg**4 + 0.5*xavg**2*dx**2 + 0.0125*dx**4), & xavg * (xavg**4 + C5_6*xavg**2*dx**2 + 0.0625*dx**4) /) - Bsys(i) = u(N-6+i) + Bsys(i) = u(N+1-i) x(i+1) = x(i) + dx enddo @@ -1360,7 +1349,7 @@ subroutine edge_values_implicit_h6( N, h, u, edge_val, h_neglect, answers_2018 ) tri_l(N+1) = 0.0 tri_d(N+1) = 1.0 tri_u(N+1) = 0.0 - tri_b(N+1) = evaluation_polynomial( Csys, 6, x(7) ) ! last edge value + tri_b(N+1) = Csys(1) ! Solve tridiagonal system and assign edge values call solve_tridiagonal_system( tri_l, tri_d, tri_u, tri_b, tri_x, N+1 ) From 515eb1121e6c51a0f781b5785033429649e1f06c Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 15 Jan 2020 19:14:19 -0500 Subject: [PATCH 029/316] (*)Use end_value_h4 in edge_slopes_implicit_h3 Use end_value_h4 to set end slopes in edge_slopes_implicit_h3. This changes answers in some cases with REMAPPING_2018_ANSWERS = False, but the existing MOM6-examples test cases are bitwise identical. --- src/ALE/regrid_edge_values.F90 | 28 ++++++++++------------------ 1 file changed, 10 insertions(+), 18 deletions(-) diff --git a/src/ALE/regrid_edge_values.F90 b/src/ALE/regrid_edge_values.F90 index ea4f3a10fb..8b5396cc3a 100644 --- a/src/ALE/regrid_edge_values.F90 +++ b/src/ALE/regrid_edge_values.F90 @@ -728,6 +728,8 @@ subroutine edge_slopes_implicit_h3( N, h, u, edge_slopes, h_neglect, answers_201 real :: alpha, beta ! stencil coefficients [nondim] real :: a, b ! weights of cells [H-1] real, parameter :: C1_12 = 1.0 / 12.0 + real, dimension(4) :: dz ! A temporary array of limited layer thicknesses [H] + real, dimension(4) :: u_tmp ! A temporary array of cell average properties [A] real, dimension(5) :: x ! Coordinate system with 0 at edges [H] real :: dx, xavg ! Differences and averages of successive values of x [H] real, dimension(4,4) :: Asys ! matrix used to find boundary conditions @@ -821,16 +823,11 @@ subroutine edge_slopes_implicit_h3( N, h, u, edge_slopes, h_neglect, answers_201 tri_d(1) = 1.0 else ! Use expressions with less sensitivity to roundoff h_min = max( hNeglect, hMinFrac * ((h(1) + h(2)) + (h(3) + h(4))) ) - x(1) = 0.0 - do i = 1,4 - dx = max(h_min, h(i) ) - x(i+1) = x(i) + dx - xavg = x(i) + 0.5*dx - Asys(1:4,i) = (/ 1.0, xavg, (xavg**2 + C1_12*dx**2), xavg * (xavg**2 + 0.25*dx**2) /) - Bsys(i) = u(i) + do i=1,4 + dz(i) = max(h_min, h(i) ) + u_tmp(i) = u(i) enddo - - call linear_solver( 4, Asys, Bsys, Csys ) + call end_value_h4(dz, u_tmp, Csys) ! Set the first edge slope tri_b(1) = Csys(2) @@ -858,19 +855,14 @@ subroutine edge_slopes_implicit_h3( N, h, u, edge_slopes, h_neglect, answers_201 ! Use expressions with less sensitivity to roundoff, including using a coordinate ! system that sets the origin at the last interface in the domain. h_min = max( hNeglect, hMinFrac * ((h(N-3) + h(N-2)) + (h(N-1) + h(N))) ) - x(1) = 0.0 - do i = 1,4 - dx = max(h_min, h(N+1-i) ) - x(i+1) = x(i) + dx - xavg = x(i) + 0.5*dx - Asys(1:4,i) = (/ 1.0, xavg, (xavg**2 + C1_12*dx**2), xavg * (xavg**2 + 0.25*dx**2) /) - Bsys(i) = u(N+1-i) + do i=1,4 + dz(i) = max(h_min, h(N+1-i) ) + u_tmp(i) = u(N+1-i) enddo - call linear_solver( 4, Asys, Bsys, Csys ) + call end_value_h4(dz, u_tmp, Csys) ! Set the last edge slope - tri_b(N+1) = -Csys(2) tri_c(N+1) = 1.0 endif From 612b1643cdfd299cdcb48827b597db9e5a1a44f5 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 16 Jan 2020 09:43:38 -0500 Subject: [PATCH 030/316] (*)Limit fractional thicknesses in end_value_h4 Set algorithmically motivated minimum fractional thicknesses in end_value_h4, and removed less germane minima in the thicknesses passed to end_value_h4. This changes answers in some cases with REMAPPING_2018_ANSWERS = False, but the existing MOM6-examples test cases are bitwise identical. --- src/ALE/regrid_edge_values.F90 | 65 ++++++++++------------------------ 1 file changed, 19 insertions(+), 46 deletions(-) diff --git a/src/ALE/regrid_edge_values.F90 b/src/ALE/regrid_edge_values.F90 index 8b5396cc3a..f262b8015d 100644 --- a/src/ALE/regrid_edge_values.F90 +++ b/src/ALE/regrid_edge_values.F90 @@ -315,13 +315,7 @@ subroutine edge_values_explicit_h4( N, h, u, edge_val, h_neglect, answers_2018 ) edge_val(1,1) = evaluation_polynomial( C, 4, x(1) ) edge_val(1,2) = evaluation_polynomial( C, 4, x(2) ) else ! Use expressions with less sensitivity to roundoff - h_min = hMinFrac*((h(1) + h(2)) + (h(3) + h(4))) - if (h_min == 0.0) h_min = 1.0 ! Handle the case of all massless layers. - - do i=1,4 - dz(i) = max(h_min, h(i) ) - u_tmp(i) = u(i) - enddo + do i=1,4 ; dz(i) = max(hNeglect, h(i) ) ; u_tmp(i) = u(i) ; enddo call end_value_h4(dz, u_tmp, C) ! Set the edge values of the first cell @@ -350,12 +344,7 @@ subroutine edge_values_explicit_h4( N, h, u, edge_val, h_neglect, answers_2018 ) else ! Use expressions with less sensitivity to roundoff, including using a coordinate ! system that sets the origin at the last interface in the domain. - h_min = hMinFrac * ((h(N-3) + h(N-2)) + (h(N-1) + h(N))) - if (h_min == 0.0) h_min = 1.0 ! Handle the case of all massless layers. - do i=1,4 - dz(i) = max(h_min, h(N+1-i) ) - u_tmp(i) = u(N+1-i) - enddo + do i=1,4 ; dz(i) = max(hNeglect, h(N+1-i) ) ; u_tmp(i) = u(N+1-i) ; enddo call end_value_h4(dz, u_tmp, C) ! Set the last and second to last edge values @@ -419,8 +408,6 @@ subroutine edge_values_implicit_h4( N, h, u, edge_val, h_neglect, answers_2018 ) real :: dx, xavg ! Differences and averages of successive values of x [H] real, dimension(4,4) :: Asys ! boundary conditions real, dimension(4) :: Bsys, Csys - real, dimension(4,4) :: Asys_orig ! boundary conditions - real, dimension(4) :: Bsys_orig real, dimension(N+1) :: tri_l, & ! tridiagonal system (lower diagonal) [nondim] tri_d, & ! tridiagonal system (middle diagonal) [nondim] tri_c, & ! tridiagonal system central value, with tri_d = tri_c+tri_l+tri_u @@ -504,15 +491,10 @@ subroutine edge_values_implicit_h4( N, h, u, edge_val, h_neglect, answers_2018 ) tri_b(1) = evaluation_polynomial( Csys, 4, x(1) ) ! Set the first edge value tri_d(1) = 1.0 else ! Use expressions with less sensitivity to roundoff - h_min = max( hNeglect, hMinFrac * ((h(1) + h(2)) + (h(3) + h(4))) ) - do i=1,4 - dz(i) = max(h_min, h(i) ) - u_tmp(i) = u(i) - enddo + do i=1,4 ; dz(i) = max(hNeglect, h(i) ) ; u_tmp(i) = u(i) ; enddo call end_value_h4(dz, u_tmp, Csys) tri_b(1) = Csys(1) ! Set the first edge value. - tri_c(1) = 1.0 endif tri_u(1) = 0.0 ! tri_l(1) = 0.0 @@ -537,16 +519,10 @@ subroutine edge_values_implicit_h4( N, h, u, edge_val, h_neglect, answers_2018 ) else ! Use expressions with less sensitivity to roundoff, including using a coordinate ! system that sets the origin at the last interface in the domain. - h_min = max( hNeglect, hMinFrac * ((h(N-3) + h(N-2)) + (h(N-1) + h(N))) ) - do i=1,4 - dz(i) = max(h_min, h(N+1-i) ) - u_tmp(i) = u(N+1-i) - enddo - + do i=1,4 ; dz(i) = max(hNeglect, h(N+1-i) ) ; u_tmp(i) = u(N+1-i) ; enddo call end_value_h4(dz, u_tmp, Csys) - ! Set the last edge value - tri_b(N+1) = Csys(1) + tri_b(N+1) = Csys(1) ! Set the last edge value tri_c(N+1) = 1.0 endif tri_l(N+1) = 0.0 ! tri_u(N+1) = 0.0 @@ -589,14 +565,15 @@ subroutine end_value_h4(dz, u, Csys) real :: I_h1234 ! The inverse of the sum of all four thicknesses [H-1] real :: I_denom ! The inverse of the denominator some expressions [H-3] real :: I_denB3 ! The inverse of the product of three sums of thicknesses [H-3] + real :: min_frac = 1.0e-6 ! The square of min_frac should be much larger than roundoff [nondim] real, parameter :: C1_3 = 1.0 / 3.0 integer :: i, j, k ! These are only used for code verification - real, dimension(4) :: Atest ! The coefficients of an expression that is being tested. - real :: zavg, u_mag, c_mag - character(len=128) :: mesg - real, parameter :: C1_12 = 1.0 / 12.0 + ! real, dimension(4) :: Atest ! The coefficients of an expression that is being tested. + ! real :: zavg, u_mag, c_mag + ! character(len=128) :: mesg + ! real, parameter :: C1_12 = 1.0 / 12.0 ! if ((dz(1) == dz(2)) .and. (dz(1) == dz(3)) .and. (dz(1) == dz(4))) then ! ! There are simple closed-form expressions in this case @@ -610,6 +587,12 @@ subroutine end_value_h4(dz, u, Csys) ! Express the coefficients as sums of the differences between properties of succesive layers. h1 = dz(1) ; h2 = dz(2) ; h3 = dz(3) ; h4 = dz(4) + ! Some of the weights used below are proportional to (h1/(h2+h3))**2 or (h1/(h2+h3))*(h2/(h3+h4)) + ! so h2 and h3 should be adjusted to ensure that these ratios are not so large that property + ! differences at the level of roundoff are amplified to be of order 1. + if ((h2+h3) < min_frac*h1) h3 = min_frac*h1 - h2 + if ((h3+h4) < min_frac*h1) h4 = min_frac*h1 - h3 + h12 = h1+h2 ; h23 = h2+h3 ; h34 = h3+h4 h123 = h12 + h3 ; h234 = h2 + h34 ; h1234 = h12 + h34 ! Find 3 reciprocals with a single division for efficiency. @@ -788,9 +771,8 @@ subroutine edge_slopes_implicit_h3( N, h, u, edge_slopes, h_neglect, answers_201 h0h1 = h0 * h1 ; h0_2 = h0 * h0 ; h1_2 = h1 * h1 h0_3 = h0_2 * h0 ; h1_3 = h1_2 * h1 - I_d = 1.0 / (4.0 * h0h1 * ( h0 + h1 ) + h1_3 + h0_3) ! = 1 / ((h0 + h1)**3 + h0*h1*(h0 + h1)) - ! Set the tridiagonal coefficients + I_d = 1.0 / (4.0 * h0h1 * ( h0 + h1 ) + h1_3 + h0_3) ! = 1 / ((h0 + h1)**3 + h0*h1*(h0 + h1)) tri_l(i+1) = (h1 * ((h0_2 + h0h1) - h1_2)) * I_d ! tri_d(i+1) = 1.0 tri_c(i+1) = 2.0 * ((h0_2 + h1_2) * (h0 + h1)) * I_d @@ -822,11 +804,7 @@ subroutine edge_slopes_implicit_h3( N, h, u, edge_slopes, h_neglect, answers_201 tri_b(1) = evaluation_polynomial( Dsys, 3, x(1) ) ! Set the first edge slope tri_d(1) = 1.0 else ! Use expressions with less sensitivity to roundoff - h_min = max( hNeglect, hMinFrac * ((h(1) + h(2)) + (h(3) + h(4))) ) - do i=1,4 - dz(i) = max(h_min, h(i) ) - u_tmp(i) = u(i) - enddo + do i=1,4 ; dz(i) = max(hNeglect, h(i) ) ; u_tmp(i) = u(i) ; enddo call end_value_h4(dz, u_tmp, Csys) ! Set the first edge slope @@ -854,11 +832,7 @@ subroutine edge_slopes_implicit_h3( N, h, u, edge_slopes, h_neglect, answers_201 else ! Use expressions with less sensitivity to roundoff, including using a coordinate ! system that sets the origin at the last interface in the domain. - h_min = max( hNeglect, hMinFrac * ((h(N-3) + h(N-2)) + (h(N-1) + h(N))) ) - do i=1,4 - dz(i) = max(h_min, h(N+1-i) ) - u_tmp(i) = u(N+1-i) - enddo + do i=1,4 ; dz(i) = max(hNeglect, h(N+1-i) ) ; u_tmp(i) = u(N+1-i) ; enddo call end_value_h4(dz, u_tmp, Csys) @@ -945,7 +919,6 @@ subroutine edge_slopes_implicit_h5( N, h, u, edge_slopes, h_neglect, answers_201 real :: dx, xavg ! Differences and averages of successive values of x [same units as h] real, dimension(6,6) :: Asys ! matrix used to find boundary conditions real, dimension(6) :: Bsys, Csys ! ... - real, dimension(5) :: Dsys ! derivative real, dimension(N+1) :: tri_l, & ! trid. system (lower diagonal) tri_d, & ! trid. system (middle diagonal) tri_u, & ! trid. system (upper diagonal) From 626bc2feba553248145ef0134854e27d42dc3005 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 16 Jan 2020 13:55:33 -0500 Subject: [PATCH 031/316] +Add optional argument tol to test_answers Allow for a finite tolerance in tests in test_answer. This is needed because (1./3. + 2./3.) is only equal to 1 to within a tolerance of order 10^-15. --- src/ALE/MOM_remapping.F90 | 31 +++++++++++++++++++------------ 1 file changed, 19 insertions(+), 12 deletions(-) diff --git a/src/ALE/MOM_remapping.F90 b/src/ALE/MOM_remapping.F90 index d886015115..6255a6fce8 100644 --- a/src/ALE/MOM_remapping.F90 +++ b/src/ALE/MOM_remapping.F90 @@ -1810,9 +1810,11 @@ logical function remapping_unit_tests(verbose) call edge_values_explicit_h4( 5, (/1.,1.,1.,1.,1./), (/1.,3.,5.,7.,9./), ppoly0_E, & h_neglect=1e-10, answers_2018=answers_2018 ) - ! 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') + ! The next two tests currently fail due to roundoff, but pass when given a reasonable tolerance. + thisTest = test_answer(v, 5, ppoly0_E(:,1), (/0.,2.,4.,6.,8./), 'Line H4: left edges', tol=8.0e-15) + remapping_unit_tests = remapping_unit_tests .or. thisTest + thisTest = test_answer(v, 5, ppoly0_E(:,2), (/2.,4.,6.,8.,10./), 'Line H4: right edges', tol=1.0e-14) + remapping_unit_tests = remapping_unit_tests .or. thisTest 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,:), & @@ -1826,9 +1828,11 @@ logical function remapping_unit_tests(verbose) call edge_values_explicit_h4( 5, (/1.,1.,1.,1.,1./), (/1.,1.,7.,19.,37./), ppoly0_E, & h_neglect=1e-10, answers_2018=answers_2018 ) - ! 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') + ! The next two tests are now passing when answers_2018 = .false., but otherwise only work to roundoff. + thisTest = test_answer(v, 5, ppoly0_E(:,1), (/3.,0.,3.,12.,27./), 'Parabola H4: left edges', tol=2.7e-14) + remapping_unit_tests = remapping_unit_tests .or. thisTest + thisTest = test_answer(v, 5, ppoly0_E(:,2), (/0.,3.,12.,27.,48./), 'Parabola H4: right edges', tol=4.8e-14) + remapping_unit_tests = remapping_unit_tests .or. thisTest 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,:), & @@ -1878,23 +1882,26 @@ logical function remapping_unit_tests(verbose) end function remapping_unit_tests !> Returns true if any cell of u and u_true are not identical. Returns false otherwise. -logical function test_answer(verbose, n, u, u_true, label) +logical function test_answer(verbose, n, u, u_true, label, tol) logical, intent(in) :: verbose !< If true, write results to stdout - integer, intent(in) :: n !< Number of cells in u - real, dimension(n), intent(in) :: u !< Values to test + integer, intent(in) :: n !< Number of cells in u + real, dimension(n), intent(in) :: u !< Values to test real, dimension(n), intent(in) :: u_true !< Values to test against (correct answer) - character(len=*), intent(in) :: label !< Message + character(len=*), intent(in) :: label !< Message + real, optional, intent(in) :: tol !< The tolerance for differences between u and u_true ! Local variables + real :: tolerance ! The tolerance for differences between u and u_true integer :: k + tolerance = 0.0 ; if (present(tol)) tolerance = tol test_answer = .false. do k = 1, n - if (u(k) /= u_true(k)) test_answer = .true. + if (abs(u(k) - u_true(k)) > tolerance) test_answer = .true. enddo if (test_answer .or. verbose) then write(*,'(a4,2a24,x,a)') 'k','Calculated value','Correct value',label do k = 1, n - if (u(k) /= u_true(k)) then + if (abs(u(k) - u_true(k)) > tolerance) then write(*,'(i4,1p2e24.16,a,1pe24.16,a)') k,u(k),u_true(k),' err=',u(k)-u_true(k),' < wrong' else write(*,'(i4,1p2e24.16)') k,u(k),u_true(k) From 4d0833c6d9b7123d359b126f8c16ea1d489de244 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 16 Jan 2020 13:58:16 -0500 Subject: [PATCH 032/316] (*)Minor refactoring of edge_values_explicit_h4 Mathematically equivalent refactoring of edge_values_explicit_h4 when REMAPPING_2018_ANSWERS is false. These new expressions should exhibit smaller errors from roundoff, but are mathematically equivalent to the previous forms. All answers in the existing MOM6-examples test cases are bitwise identical. --- src/ALE/regrid_edge_values.F90 | 40 ++++++++++++++++++---------------- 1 file changed, 21 insertions(+), 19 deletions(-) diff --git a/src/ALE/regrid_edge_values.F90 b/src/ALE/regrid_edge_values.F90 index f262b8015d..4f7833a2d8 100644 --- a/src/ALE/regrid_edge_values.F90 +++ b/src/ALE/regrid_edge_values.F90 @@ -228,12 +228,14 @@ subroutine edge_values_explicit_h4( N, h, u, edge_val, h_neglect, answers_2018 ) logical, optional, intent(in) :: answers_2018 !< If true use older, less acccurate expressions. ! Local variables - integer :: i, j - real :: h0, h1, h2, h3 ! temporary thicknesses [H] - real :: h_sum ! A sum of adjacent thicknesses [H] - real :: h_min ! A minimal cell width [H] - real :: f1, f2, f3 ! auxiliary variables with various units - real :: et1, et2, et3 ! terms the expresson for edge values [A H] + real :: h0, h1, h2, h3 ! temporary thicknesses [H] + real :: h_sum ! A sum of adjacent thicknesses [H] + real :: h_min ! A minimal cell width [H] + real :: f1, f2, f3 ! auxiliary variables with various units + real :: et1, et2, et3 ! terms the expresson for edge values [A H] + real :: I_h12 ! The inverse of the sum of the two central thicknesses [H-1] + real :: I_h012, I_h123 ! Inverses of sums of three succesive thicknesses [H-1] + real :: I_den_et2, I_den_et3 ! Inverses of denominators in edge value terms [H-2] real, dimension(5) :: x ! Coordinate system with 0 at edges [H] real, dimension(4) :: dz ! A temporary array of limited layer thicknesses [H] real, dimension(4) :: u_tmp ! A temporary array of cell average properties [A] @@ -242,6 +244,7 @@ subroutine edge_values_explicit_h4( N, h, u, edge_val, h_neglect, answers_2018 ) real, dimension(4,4) :: A ! values near the boundaries real, dimension(4) :: B, C real :: hNeglect ! A negligible thickness in the same units as h. + integer :: i, j logical :: use_2018_answers ! If true use older, less acccurate expressions. use_2018_answers = .true. ; if (present(answers_2018)) use_2018_answers = answers_2018 @@ -277,21 +280,20 @@ subroutine edge_values_explicit_h4( N, h, u, edge_val, h_neglect, answers_2018 ) f2 = h2 * u(i-1) + h1 * u(i) f3 = 1.0 / (h0+h1+h2) + 1.0 / (h1+h2+h3) et1 = f1 * f2 * f3 - else - et1 = ( (h0+h1) * (h2+h3) * ((h1+h2+h3) + (h0+h1+h2)) / & - (((h1+h2) * ((h0+h1+h2) * (h1+h2+h3)))) ) * & - (h2 * u(i-1) + h1 * u(i)) - endif - - et2 = ( h2 * (h2+h3) / ( (h0+h1+h2)*(h0+h1) ) ) * & - ((h0+2.0*h1) * u(i-1) - h1 * u(i-2)) - - et3 = ( h1 * (h0+h1) / ( (h1+h2+h3)*(h2+h3) ) ) * & - ((2.0*h2+h3) * u(i) - h2 * u(i+1)) - - if (use_2018_answers) then + et2 = ( h2 * (h2+h3) / ( (h0+h1+h2)*(h0+h1) ) ) * & + ((h0+2.0*h1) * u(i-1) - h1 * u(i-2)) + et3 = ( h1 * (h0+h1) / ( (h1+h2+h3)*(h2+h3) ) ) * & + ((2.0*h2+h3) * u(i) - h2 * u(i+1)) edge_val(i,1) = (et1 + et2 + et3) / ( h0 + h1 + h2 + h3) else + I_h12 = 1.0 / (h1+h2) + I_den_et2 = 1.0 / ( ((h0+h1)+h2)*(h0+h1) ) ; I_h012 = (h0+h1) * I_den_et2 + I_den_et3 = 1.0 / ( (h1+(h2+h3))*(h2+h3) ) ; I_h123 = (h2+h3) * I_den_et3 + + et1 = ( 1.0 + (h1 * I_h012 + (h0+h1) * I_h123) ) * I_h12 * (h2*(h2+h3)) * u(i-1) + & + ( 1.0 + (h2 * I_h123 + (h2+h3) * I_h012) ) * I_h12 * (h1*(h0+h1)) * u(i) + et2 = ( h1 * (h2*(h2+h3)) * I_den_et2 ) * (u(i-1)-u(i-2)) + et3 = ( h2 * (h1*(h0+h1)) * I_den_et3 ) * (u(i) - u(i+1)) edge_val(i,1) = (et1 + (et2 + et3)) / ((h0 + h1) + (h2 + h3)) endif edge_val(i-1,2) = edge_val(i,1) From f94dd0c9c41dd138e93237c0402874c1d8700a64 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 16 Jan 2020 17:05:05 -0500 Subject: [PATCH 033/316] Added dOxygen comments to test_line Added the missing dOxygen comments to the debugging routine test_line in regrid_edge_values.F90. All answers are bitwise identical. --- src/ALE/regrid_edge_values.F90 | 26 ++++++++++++-------------- 1 file changed, 12 insertions(+), 14 deletions(-) diff --git a/src/ALE/regrid_edge_values.F90 b/src/ALE/regrid_edge_values.F90 index 4f7833a2d8..46570b26b9 100644 --- a/src/ALE/regrid_edge_values.F90 +++ b/src/ALE/regrid_edge_values.F90 @@ -658,7 +658,7 @@ subroutine end_value_h4(dz, u, Csys) ! Atest(4) = zavg * (zavg**2 + 0.25*dz(i)**2) ! = ( (z(i+1)**4) - (z(i)**4) ) / (4*dz(i)) ! c_mag = 1.0 ; do k=0,3 ; do j=1,3 ; c_mag = c_mag + abs(Wt(j,k+1) * zavg**k) ; enddo ; enddo ! write(mesg, '("end_value_h4 line ", i2, " c_mag = ", es10.2, " u_mag = ", es10.2)') i, c_mag, u_mag -! call test_line(mesg, 4, Atest, Csys, u(i), u_mag*c_mag, tolerance=1.0e-15) +! call test_line(mesg, 4, Atest, Csys, u(i), u_mag*c_mag, tol=1.0e-15) ! enddo end subroutine end_value_h4 @@ -1440,36 +1440,34 @@ end subroutine linear_solver -! Verify that A*C = R to within roundoff. -subroutine test_line(msg, N, A, C, R, mag, tolerance) - integer, intent(in) :: N - real, dimension(4), intent(in) :: A - real, dimension(4), intent(in) :: C - real, intent(in) :: R +!> Test that A*C = R to within a tolerance, issuing a fatal error with an explanatory message if they do not. +subroutine test_line(msg, N, A, C, R, mag, tol) real, intent(in) :: mag !< The magnitude of leading order terms in this line - real, optional, intent(in) :: tolerance - character(len=*) :: msg + integer, intent(in) :: N !< The number of points in the system + real, dimension(4), intent(in) :: A !< One of the two vectors being multiplied + real, dimension(4), intent(in) :: C !< One of the two vectors being multiplied + real, intent(in) :: R !< The expected solution of the equation + character(len=*), intent(in) :: msg !< An identifying message for this test + real, optional, intent(in) :: tol !< The fractional tolerance for the two solutions real :: sum, sum_mag - real :: tol + real :: tolerance character(len=128) :: mesg2 integer :: i - tol = 1.0e-12 ; if (present(tolerance)) tol = tolerance + tolerance = 1.0e-12 ; if (present(tol)) tolerance = tol sum = 0.0 ; sum_mag = max(0.0,mag) - do i=1,N sum = sum + A(i) * C(i) sum_mag = sum_mag + abs(A(i) * C(i)) enddo - if (abs(sum - R) > tol * (sum_mag + abs(R))) then + if (abs(sum - R) > tolerance * (sum_mag + abs(R))) then write(mesg2, '(", Fractional error = ", es12.4,", sum = ", es12.4)') (sum - R) / (sum_mag + abs(R)), sum call MOM_error(FATAL, "Failed line test: "//trim(msg)//trim(mesg2)) endif end subroutine test_line - end module regrid_edge_values From ddb9f4791fc15b23e55fb8f6d11fab5498c0e935 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sat, 18 Jan 2020 15:36:04 -0500 Subject: [PATCH 034/316] (*)Fixed geothermal with vanished layers Corrected the behavior of geothermal with vanishing layers. With this change, all of the MOM6-examples test cases work with DEFAULT_2018_ANSWERS=False and ANGSTROM=0.0. All answers in the existing MOM6-examples test cases are bitwise identical. --- src/parameterizations/vertical/MOM_geothermal.F90 | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/parameterizations/vertical/MOM_geothermal.F90 b/src/parameterizations/vertical/MOM_geothermal.F90 index 649d59e619..f11cd374bf 100644 --- a/src/parameterizations/vertical/MOM_geothermal.F90 +++ b/src/parameterizations/vertical/MOM_geothermal.F90 @@ -303,10 +303,10 @@ subroutine geothermal(h, tv, dt, ea, eb, G, GV, US, CS, halo) endif heat_rem(i) = heat_rem(i) - heating - I_h = 1.0 / (h(i,j,k_tgt) + h_transfer + H_neglect) - tv%T(i,j,k_tgt) = (h(i,j,k_tgt) * tv%T(i,j,k_tgt) + & + I_h = 1.0 / ((h(i,j,k_tgt) + H_neglect) + h_transfer) + tv%T(i,j,k_tgt) = ((h(i,j,k_tgt) + H_neglect) * tv%T(i,j,k_tgt) + & (h_transfer * tv%T(i,j,k) + heating)) * I_h - tv%S(i,j,k_tgt) = (h(i,j,k_tgt) * tv%S(i,j,k_tgt) + & + tv%S(i,j,k_tgt) = ((h(i,j,k_tgt) + H_neglect) * tv%S(i,j,k_tgt) + & h_transfer * tv%S(i,j,k)) * I_h h(i,j,k) = h(i,j,k) - h_transfer From 14376099fccc36b9525d0e2a40779fa0a4fbd4d2 Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Thu, 12 Dec 2019 16:02:35 +0000 Subject: [PATCH 035/316] Correct spelling in HI doxumentation --- src/framework/MOM_hor_index.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/framework/MOM_hor_index.F90 b/src/framework/MOM_hor_index.F90 index 2fda7bd68d..8f7ce1db8e 100644 --- a/src/framework/MOM_hor_index.F90 +++ b/src/framework/MOM_hor_index.F90 @@ -113,7 +113,7 @@ end subroutine HIT_assign !> \namespace mom_hor_index !! -!! The hor_index_type provides the decalarations and loop ranges for almost all data with horizontal extent. +!! The hor_index_type provides the declarations and loop ranges for almost all data with horizontal extent. !! !! Declarations and loop ranges should always be coded with the symmetric memory model in mind. !! The non-symmetric memory mode will then also work, albeit with a different (less efficient) communication pattern. From a2dfe21cbadbc999f9293705256495c3182a4fcb Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Thu, 12 Dec 2019 16:08:28 +0000 Subject: [PATCH 036/316] Adds global extents to hor_index type - niglobal,njglobal are available from the Domain type and usually accessed via a ocean_grid_type function. Modules that do not need the Domain but do use the hor_index type are obliged to use the ocean_grid_type to get the global extent, even though it's just integer information most closely related to the indices. - This commit adds niglobal,njglobal to the hor_index type so that modules that use HI, and only need indices, do not need to the full ocean_grid_type. --- src/framework/MOM_hor_index.F90 | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/src/framework/MOM_hor_index.F90 b/src/framework/MOM_hor_index.F90 index 8f7ce1db8e..db52afcdd8 100644 --- a/src/framework/MOM_hor_index.F90 +++ b/src/framework/MOM_hor_index.F90 @@ -3,7 +3,7 @@ module MOM_hor_index ! This file is part of MOM6. See LICENSE.md for the license. -use MOM_domains, only : MOM_domain_type, get_domain_extent +use MOM_domains, only : MOM_domain_type, get_domain_extent, get_global_shape use MOM_error_handler, only : MOM_error, MOM_mesg, FATAL use MOM_file_parser, only : get_param, log_param, log_version, param_file_type @@ -46,6 +46,9 @@ module MOM_hor_index integer :: idg_offset !< The offset between the corresponding global and local i-indices. integer :: jdg_offset !< The offset between the corresponding global and local j-indices. logical :: symmetric !< True if symmetric memory is used. + + integer :: niglobal !< The global number of h-cells in the i-direction + integer :: njglobal !< The global number of h-cells in the j-direction end type hor_index_type !> Copy the contents of one horizontal index type into another @@ -71,6 +74,7 @@ subroutine hor_index_init(Domain, HI, param_file, local_indexing, index_offset) HI%isg, HI%ieg, HI%jsg, HI%jeg, & HI%idg_offset, HI%jdg_offset, HI%symmetric, & local_indexing=local_indexing) + call get_global_shape(Domain, HI%niglobal, HI%njglobal) ! Read all relevant parameters and write them to the model log. call log_version(param_file, "MOM_hor_index", version, & @@ -108,6 +112,7 @@ subroutine HIT_assign(HI1, HI2) HI1%idg_offset = HI2%idg_offset ; HI1%jdg_offset = HI2%jdg_offset HI1%symmetric = HI2%symmetric + HI1%niglobal = HI2%niglobal ; HI1%njglobal = HI2%njglobal end subroutine HIT_assign From 0409fb239b034fa7baf35ca5b5bc6fc096097bde Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Mon, 20 Jan 2020 18:07:17 +0000 Subject: [PATCH 037/316] Adds MOM_random module - MOM_random provides a wrapper to the Mersenne twister pseudo-random number generator in FMS. In particular it allows for reproducible 2d fields of numbers using the MOM6 domain decomposition. - Commit includes unit tests that check specific values as well as the statistics (the latter are not unit tests but there's no harm in doing them). --- src/core/MOM_unit_tests.F90 | 3 + src/framework/MOM_random.F90 | 458 +++++++++++++++++++++++++++++++++++ 2 files changed, 461 insertions(+) create mode 100644 src/framework/MOM_random.F90 diff --git a/src/core/MOM_unit_tests.F90 b/src/core/MOM_unit_tests.F90 index ff5a93a62c..e01348f087 100644 --- a/src/core/MOM_unit_tests.F90 +++ b/src/core/MOM_unit_tests.F90 @@ -9,6 +9,7 @@ module MOM_unit_tests use MOM_remapping, only : remapping_unit_tests use MOM_neutral_diffusion, only : neutral_diffusion_unit_tests use MOM_diag_vkernels, only : diag_vkernels_unit_tests +use MOM_random, only : random_unit_tests implicit none ; private @@ -35,6 +36,8 @@ subroutine unit_tests(verbosity) "MOM_unit_tests: neutralDiffusionUnitTests FAILED") if (diag_vkernels_unit_tests(verbose)) call MOM_error(FATAL, & "MOM_unit_tests: diag_vkernels_unit_tests FAILED") + if (random_unit_tests(verbose)) call MOM_error(FATAL, & + "MOM_unit_tests: random_unit_tests FAILED") endif end subroutine unit_tests diff --git a/src/framework/MOM_random.F90 b/src/framework/MOM_random.F90 new file mode 100644 index 0000000000..6e254abed2 --- /dev/null +++ b/src/framework/MOM_random.F90 @@ -0,0 +1,458 @@ +!> Provides gridded random number capability +module MOM_random + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_hor_index, only : hor_index_type +use MOM_time_manager, only : time_type, set_date, get_date + +use MersenneTwister_mod, only : randomNumberSequence ! Random number class from FMS +use MersenneTwister_mod, only : new_RandomNumberSequence ! Constructor/initializer +use MersenneTwister_mod, only : getRandomReal ! Generates a random number +use MersenneTwister_mod, only : getRandomPositiveInt ! Generates a random positive integer + +implicit none ; private + +public :: random_0d_constructor +public :: random_01 +public :: random_norm +public :: random_2d_constructor +public :: random_2d_01 +public :: random_2d_norm +public :: random_unit_tests + +#include + +!> Container for pseudo-random number generators +type, public :: PRNG ; private + + !> Scalar random number generator for whole model + type(randomNumberSequence) :: stream0d + + !> Random number generator for each cell on horizontal grid + type(randomNumberSequence), dimension(:,:), allocatable :: stream2d + +end type PRNG + +contains + +!> Returns a random number between 0 and 1 +real function random_01(CS) + type(PRNG), intent(inout) :: CS !< Container for pseudo-random number generators + + random_01 = getRandomReal(CS%stream0d) + +end function random_01 + +!> Returns an approximately normally distributed random number with mean 0 and variance 1 +real function random_norm(CS) + type(PRNG), intent(inout) :: CS !< Container for pseudo-random number generators + ! Local variables + integer :: i + + random_norm = getRandomReal(CS%stream0d) - 0.5 + do i = 1,11 + random_norm = random_norm + ( getRandomReal(CS%stream0d) - 0.5 ) + enddo + +end function random_norm + +!> Generates random numbers between 0 and 1 for each cell of the model grid +subroutine random_2d_01(CS, HI, rand) + type(PRNG), intent(inout) :: CS !< Container for pseudo-random number generators + type(hor_index_type), intent(in) :: HI !< Horizontal index structure + real, dimension(SZI_(HI),SZJ_(HI)), intent(out) :: rand !< Random numbers between 0 and 1 + ! Local variables + integer :: i,j + + do j = HI%jsd,HI%jed + do i = HI%isd,HI%ied + rand(i,j) = getRandomReal( CS%stream2d(i,j) ) + enddo + enddo + +end subroutine random_2d_01 + +!> Returns an approximately normally distributed random number with mean 0 and variance 1 +!! for each cell of the model grid +subroutine random_2d_norm(CS, HI, rand) + type(PRNG), intent(inout) :: CS !< Container for pseudo-random number generators + type(hor_index_type), intent(in) :: HI !< Horizontal index structure + real, dimension(SZI_(HI),SZJ_(HI)), intent(out) :: rand !< Random numbers between 0 and 1 + ! Local variables + integer :: i,j,n + + do j = HI%jsd,HI%jed + do i = HI%isd,HI%ied + rand(i,j) = getRandomReal( CS%stream2d(i,j) ) - 0.5 + enddo + do n = 1,11 + do i = HI%isd,HI%ied + rand(i,j) = rand(i,j) + ( getRandomReal( CS%stream2d(i,j) ) - 0.5 ) + enddo + enddo + enddo + +end subroutine random_2d_norm + +!> Constructor for scalar PRNG. Can be used to reset the sequence. +subroutine random_0d_constructor(CS, Time, seed) + type(PRNG), intent(inout) :: CS !< Container for pseudo-random number generators + type(time_type), intent(in) :: Time !< Current model time + integer, intent(in) :: seed !< Seed for PRNG + ! Local variables + integer :: tseed + + tseed = seed_from_time(Time) + tseed = ieor(tseed, seed) + CS%stream0d = new_RandomNumberSequence(tseed) + +end subroutine random_0d_constructor + +!> Constructor for gridded PRNG. Can be used to reset the sequence. +subroutine random_2d_constructor(CS, HI, Time, seed) + type(PRNG), intent(inout) :: CS !< Container for pseudo-random number generators + type(hor_index_type), intent(in) :: HI !< Horizontal index structure + type(time_type), intent(in) :: Time !< Current model time + integer, intent(in) :: seed !< Seed for PRNG + ! Local variables + integer :: i,j,sseed,tseed + + if (.not. allocated(CS%stream2d)) allocate( CS%stream2d(HI%isd:HI%ied,HI%jsd:HI%jed) ) + + tseed = seed_from_time(Time) + tseed = ieor(tseed*9007, seed) + do j = HI%jsd,HI%jed + do i = HI%isd,HI%ied + sseed = seed_from_index(HI, i, j) + sseed = ieor(tseed, sseed*7993) + CS%stream2d(i,j) = new_RandomNumberSequence(sseed) + enddo + enddo + +end subroutine random_2d_constructor + +!> Return a seed derived as hash of values in Time +integer function seed_from_time(Time) + type(time_type), intent(in) :: Time !< Current model time + ! Local variables + integer :: yr,mo,dy,hr,mn,sc,s1,s2 + + call get_date(Time,yr,mo,dy,hr,mn,sc) + s1 = sc + 61*(mn + 61*hr) + 379 ! Range 379 .. 89620 + ! Fun fact: 2147483647 is the eighth Mersenne prime. + ! This is not the reason for using 2147483647+1 here. + s2 = mod(dy + 32*(mo + 13*yr), 2147483648) ! Range 0 .. 2147483647 + seed_from_time = ieor(s1*4111, s2) + +end function seed_from_time + +!> Create seed from position index +integer function seed_from_index(HI, i, j) + type(hor_index_type), intent(in) :: HI !< Horizontal index structure + integer, intent(in) :: i !< i-index (of h-cell) + integer, intent(in) :: j !< j-index (of h-cell) + ! Local variables + integer :: ig, jg, ni, nj, ij + + ni = HI%niglobal + nj = HI%njglobal + ! Periodicity is assumed here but does not break non-periodic models + ig = mod(HI%idg_offset + i - 1 + ni, ni)+1 + jg = max(HI%jdg_offset + j, 0) + if (jg>nj) then ! Tri-polar hard-coded until we put needed info in HI **TODO** + jg = 2*nj+1-jg + ig = ni+1-ig + endif + seed_from_index = ig + ni*(jg-1) + +end function seed_from_index + +!> Destructor for PRNG +subroutine random_destruct(CS) + type(PRNG), pointer :: CS !< Container for pseudo-random number generators + + if (allocated(CS%stream2d)) deallocate(CS%stream2d) + !deallocate(CS) +end subroutine random_destruct + +!> Runs some statistical tests on the PRNG +logical function random_unit_tests(verbose) + logical :: verbose !< True if results should be written to stdout + ! Local variables + type(PRNG) :: test_rng ! Generator + type(time_type) :: Time ! Model time + real :: r1, r2, r3 ! Some random numbers and re-used work variables + real :: mean, var, ar1, std ! Some statistics + integer :: stdunit ! For messages + integer, parameter :: n_samples = 800 + integer :: i, j, ni, nj + ! Fake being on a decomposed domain + type(hor_index_type), pointer :: HI => null() !< Not the real HI + real, dimension(:,:), allocatable :: r2d ! Random numbers + + ! Fake a decomposed domain + ni = 6 + nj = 9 + allocate(HI) + HI%isd = 0 + HI%ied = ni+1 + HI%jsd = 0 + HI%jed = nj+1 + HI%niglobal = ni + HI%njglobal = nj + HI%idg_offset = 0 + HI%jdg_offset = 0 + + random_unit_tests = .false. + stdunit = 6 + write(stdunit,'(1x,a)') '==== MOM_random: random_unit_tests =======================' + + if (verbose) write(stdunit,'(1x,"random: ",a)') '-- Time-based seeds ---------------------' + ! Check time-based seed generation + Time = set_date(1903, 11, 21, 13, 47, 29) + i = seed_from_time(Time) + random_unit_tests = random_unit_tests .or. & + test_fn(verbose, i==212584341, 'time seed 1903/11/21 13:47:29', ivalue=i) + Time = set_date(1903, 11, 22, 13, 47, 29) + i = seed_from_time(Time) + random_unit_tests = random_unit_tests .or.& + test_fn(verbose, i==212584342, 'time seed 1903/11/22 13:47:29', ivalue=i) + Time = set_date(1903, 11, 21, 13, 47, 30) + i = seed_from_time(Time) + random_unit_tests = random_unit_tests .or.& + test_fn(verbose, i==212596634, 'time seed 1903/11/21 13:47:30', ivalue=i) + + if (verbose) write(stdunit,'(1x,"random: ",a)') '-- PRNG tests ---------------------------' + ! Generate a random number, r1 + call random_0d_constructor(test_rng, Time, 1) + r1 = random_01(test_rng) + random_unit_tests = random_unit_tests .or. & + test_fn(verbose, abs(r1-4.75310122e-2)<1.e-9, 'first call', r1) + + ! Check that we get a different number, r2, on a second call + r2 = random_01(test_rng) + random_unit_tests = random_unit_tests .or. & + test_fn(verbose, abs(r2-2.71289742e-1)<1.e-9, 'consecutive test', r2) + + ! Check that we can reproduce r1 by resetting the seed + call random_0d_constructor(test_rng, Time, 1) + r2 = random_01(test_rng) + random_unit_tests = random_unit_tests .or. & + test_fn(verbose, abs(r2-r1)==0., 'reproduce test', r2) + + ! Check that we get a different number, r2, with a different seed but same date + call random_0d_constructor(test_rng, Time, 2) + r2 = random_01(test_rng) + random_unit_tests = random_unit_tests .or. & + test_fn(verbose, abs(r2-7.15508473e-1)<1.e-9, 'different seed test', r2) + + ! Check that we get a different number, r2, for a different date but same seed + Time = set_date(1903, 11, 21, 13, 0, 29) + call random_0d_constructor(test_rng, Time, 1) + r2 = random_01(test_rng) + random_unit_tests = random_unit_tests .or. & + test_fn(verbose, abs(r2-9.56667163e-1)<1.e-9, 'different date test', r2) + + if (verbose) write(stdunit,'(1x,"random: ",a)') '-- index-based seeds --------------------' + ! Check index-based seed + i = seed_from_index(HI,1,1) + random_unit_tests = random_unit_tests .or. test_fn(verbose, i==1, 'seed from index (1,1)', ivalue=i) + j = seed_from_index(HI,ni+1,1) + random_unit_tests = random_unit_tests .or. test_fn(verbose, j==i, 'seed from index (n+1,1)', ivalue=j) + i = seed_from_index(HI,ni,1) + random_unit_tests = random_unit_tests .or. test_fn(verbose, i==6, 'seed from index (n,1)', ivalue=i) + j = seed_from_index(HI,0,1) + random_unit_tests = random_unit_tests .or. test_fn(verbose, j==i, 'seed from index (0,1)', ivalue=j) + i = seed_from_index(HI,1,nj) + random_unit_tests = random_unit_tests .or. test_fn(verbose, i==49, 'seed from index (1,n)', ivalue=i) + j = seed_from_index(HI,ni,nj+1) + random_unit_tests = random_unit_tests .or. test_fn(verbose, j==i, 'seed from index (n,n+1)', ivalue=j) + i = seed_from_index(HI,ni,nj) + random_unit_tests = random_unit_tests .or. test_fn(verbose, i==54, 'seed from index (n,n)', ivalue=i) + j = seed_from_index(HI,1,nj+1) + random_unit_tests = random_unit_tests .or. test_fn(verbose, j==i, 'seed from index (1,n+1)', ivalue=j) + + if (.not.random_unit_tests) write(stdunit,'(1x,a)') 'Passed unit tests' + ! The rest of these are not unit tests but statistical tests and as such + ! could fail for different sample sizes but happen to pass here. + + ! Check statistics of large samples for uniform generator + mean = 0. ; var = 0. ; ar1 = 0. ; r2 = 0. + do i = 1, n_samples + r1 = random_01(test_rng) - 0.5 + mean = mean + r1 + var = var + r1**2 + ar1 = ar1 + r1*r2 + r2 = r1 ! Keep copy of last value + enddo + mean = mean / real(n_samples) ! Expected mean is 0 + var = var / real(n_samples) ! Expected variance is 1/12 + ar1 = ar1 / real(n_samples-1) ! Autocovariance + std = sqrt(var) ! Expected std is sqrt(1/12) + r2 = mean*sqrt(real(12*n_samples)) ! Normalized error in mean + r3 = std*sqrt(12.) ! Normalized standard deviation + r1 = ( ar1 * sqrt(real(n_samples-1)) ) / var + if (verbose) then + write(stdunit,'(1x,"random: ",a)') '-- Uniform -0.5 .. 0.5 generator --------' + write(stdunit,'(1x,"random: ",a,f12.9)') 'mean =',mean,'std =',std,'AR1 =',ar1 + write(stdunit,'(1x,"random: ",a,f12.9)') 'norm. mean =',r2, & + 'norm. std =',r3,'norm. AR1 =',r1 + endif + random_unit_tests = random_unit_tests .or. & + test_fn(verbose, abs(r2)<2., & + 'n>>1, mean within 2 sigma [uniform]', r2) + random_unit_tests = random_unit_tests .or. & + test_fn(verbose, abs(r3-1.)<1./sqrt(real(n_samples)), & + 'n>>1, std ~ 1/sqrt(12) [uniform]', r3-1.) + random_unit_tests = random_unit_tests .or. & + test_fn(verbose, abs(r1)<2., & + 'n>>1, AR1 < std/sqrt(n) [uniform]', r1) + + ! Check statistics of large samples for normal generator + mean = 0. ; var = 0. ; ar1 = 0. ; r2 = 0. + do i = 1, n_samples + r1 = random_norm(test_rng) + mean = mean + r1 + var = var + r1**2 + ar1 = ar1 + r1*r2 + r2 = r1 ! Keep copy of last value for AR calculation + enddo + mean = mean / real(n_samples) + var = var / real(n_samples) + ar1 = ar1 / real(n_samples) + std = sqrt(var) + r3 = 1./sqrt(real(n_samples)) ! Standard error of mean + r2 = mean*sqrt(real(n_samples)) ! Normalized error in mean + r3 = std ! Normalized standard deviation + r1 = ( ar1 * sqrt(real(n_samples-1)) ) / var + if (verbose) then + write(stdunit,'(1x,"random: ",a)') '-- Normal distribution generator --------' + write(stdunit,'(1x,"random: ",a,f12.9)') 'mean =',mean,'std =',std,'AR1 =',ar1 + write(stdunit,'(1x,"random: ",a,f12.9)') 'norm. error in mean =',r2, & + 'norm. standard deviation =',r3,'norm. AR1 =',r1 + endif + random_unit_tests = random_unit_tests .or. & + test_fn(verbose, abs(r2)<2., & + 'n>>1, mean within 2 sigma [norm]', r2) + random_unit_tests = random_unit_tests .or. & + test_fn(verbose, abs(r3-1.)<1./sqrt(real(n_samples)), & + 'n>>1, std ~ 1 [norm]', r3-1.) + random_unit_tests = random_unit_tests .or. & + test_fn(verbose, abs(r1)<2., & + 'n>>1, AR1 < std/sqrt(n) [norm]', r1) + + if (verbose) write(stdunit,'(1x,"random: ",a)') '-- 2d PRNG ------------------------------' + ! Check 2d random number generator 0..1 + allocate( r2d(HI%isd:HI%ied,HI%jsd:HI%jed) ) + call random_2d_constructor(test_rng, HI, Time, 123) + r2d(:,:) = -999. ! Use -9. to detect unset values + call random_2d_01(test_rng, HI, r2d) + if (any(abs(r2d(:,:)+999.)<=0.)) random_unit_tests=.true. + r1 = minval(r2d) + r2 = maxval(r2d) + random_unit_tests = random_unit_tests .or. test_fn(verbose, r1>=0., '2d all set', r1) + random_unit_tests = random_unit_tests .or. test_fn(verbose, r2<=1., '2d all valid', r2) + mean = sum( r2d(1:ni,1:nj) - 0.5 )/real(ni*nj) + var = sum( (r2d(1:ni,1:nj) - 0.5 - mean)**2 )/real(ni*nj) + std = sqrt(var) + r3 = 1./sqrt(real(12*ni*nj)) ! Standard error of mean + r2 = mean*sqrt(real(12*ni*nj)) ! Normalized error in mean + r3 = std*sqrt(12.) ! Normalized standard deviation + if (verbose) then + write(stdunit,'(1x,"random: ",a)') '2D uniform 0..1 generator' + write(stdunit,'(1x,"random: ",a,f12.9)') 'mean =',mean,'std =',std + write(stdunit,'(1x,"random: ",a,f12.9)') 'norm. error in mean =',r2 + write(stdunit,'(1x,"random: ",a,f12.9)') 'norm. standard deviation =',r3 + endif + random_unit_tests = random_unit_tests .or. & + test_fn(verbose, abs(r2)<2., & + '2d, mean within 2 sigma [uniform]', r2) + random_unit_tests = random_unit_tests .or. & + test_fn(verbose, abs(r3-1.)<1./sqrt(real(ni*nj)), & + '2d, std ~ 1/sqrt(12) [uniform]', r3-1.) + if (verbose) then + write(stdunit,'(1x,"random:")') + write(stdunit,'(1x,"random:",8f8.5)') r2d + write(stdunit,'(1x,"random:")') + endif + + ! Check 2d normal random number generator + call random_2d_norm(test_rng, HI, r2d) + mean = sum( r2d(1:ni,1:nj) )/real(ni*nj) + var = sum( r2d(1:ni,1:nj)**2 )/real(ni*nj) + std = sqrt(var) + r3 = 1./sqrt(real(ni*nj)) ! Standard error of mean + r2 = mean*sqrt(real(ni*nj)) ! Normalized error in mean + r3 = std ! Normalized standard deviation + if (verbose) then + write(stdunit,'(1x,"random: ",a)') '2D normal generator' + write(stdunit,'(1x,"random: ",a,f12.9)') 'mean =',mean,'std =',std + write(stdunit,'(1x,"random: ",a,f12.9)') 'norm. error in mean =',r2 + write(stdunit,'(1x,"random: ",a,f12.9)') 'norm. standard deviation =',r3 + endif + random_unit_tests = random_unit_tests .or. & + test_fn(verbose, abs(r2)<2., & + '2d, mean within 2 sigma [norm]', r2) + random_unit_tests = random_unit_tests .or. & + test_fn(verbose, abs(r3-1.)<1./sqrt(real(ni*nj)), & + '2d, std ~ 1/sqrt(12) [norm]', r3-1.) + + ! Clean up + deallocate(r2d) + deallocate(HI) + + if (.not.random_unit_tests) write(stdunit,'(1x,a)') 'Passed statistical tests' + +end function random_unit_tests + +!> Convenience function for reporting result of test +logical function test_fn(verbose, good, label, rvalue, ivalue) + logical, intent(in) :: verbose !< Verbosity + logical, intent(in) :: good !< True if pass, false otherwise + character(len=*), intent(in) :: label !< Label for messages + real, intent(in) :: rvalue !< Result of calculation + integer, intent(in) :: ivalue !< Result of calculation + optional :: rvalue, ivalue + + if (present(ivalue)) then + if (.not. good) then + write(0,'(1x,a,i10,1x,a,a)') 'random: result =',ivalue,label,' <------- FAIL!' + elseif (verbose) then + write(6,'(1x,a,i10,1x,a)') 'random: result =',ivalue,label + endif + else + if (.not. good) then + write(0,'(1x,a,1pe15.8,1x,a,a)') 'random: result =',rvalue,label,' <------- FAIL!' + elseif (verbose) then + write(6,'(1x,a,1pe15.8,1x,a)') 'random: result =',rvalue,label + endif + endif + test_fn = .not. good + +end function test_fn + +end module MOM_random + +!> \namespace mom_random +!! +!! Provides MOM6 wrappers to the FMS implementation of the Mersenne twister. +!! +!! Example usage: +!! \code +!! type(PRNG) :: rng +!! real :: rn +!! call random_0d_constructor(rng, Time, seed) ! Call this each time-step +!! rn = random_01(rng) +!! rn = random_norm(rng) +!! +!! type(PRNG) :: rng +!! real, dimension(:,:) :: rn2d +!! call random_2d_constructor(rng, HI, Time, seed) ! Call this each time-step +!! call random_2d_01(rng, HI, rn2d) +!! call random_2d_norm(rng, HI, rn2d) +!! +!! Note: reproducibility across restarts is implemented by using time-derived +!! seeds to pass to the Mersenne twister. It is therefore important that any +!! PRNG type be re-initialized each time-step. +!! \endcode From f61a4b9b22285ef1ec6aa62f004eacde952694a3 Mon Sep 17 00:00:00 2001 From: "brandon.reichl" Date: Thu, 23 Jan 2020 08:32:16 -0500 Subject: [PATCH 038/316] Add ability to include tides in bottom velocity component for BBL. - Adds a flag to read from tide file (BBL_USE_TIDAL_BG) - Uses an existing input for the tide file filename (TIDEAMP_FILE) - When BBL_USE_TIDAL_BG is true, MOM_set_viscosity.F90 now reads in the RMS tidal velocity from the tideamp_file and then uses the square of the RMS tidal velocity in place of the background velocity squared to compute bottom friction. --- .../vertical/MOM_set_viscosity.F90 | 84 ++++++++++++++++--- 1 file changed, 73 insertions(+), 11 deletions(-) diff --git a/src/parameterizations/vertical/MOM_set_viscosity.F90 b/src/parameterizations/vertical/MOM_set_viscosity.F90 index 0aaba9d3cf..faa1bbc7fe 100644 --- a/src/parameterizations/vertical/MOM_set_viscosity.F90 +++ b/src/parameterizations/vertical/MOM_set_viscosity.F90 @@ -14,6 +14,7 @@ module MOM_set_visc use MOM_forcing_type, only : forcing, mech_forcing use MOM_grid, only : ocean_grid_type use MOM_hor_index, only : hor_index_type +use MOM_io, only : slasher, MOM_read_data use MOM_kappa_shear, only : kappa_shear_is_used, kappa_shear_at_vertex use MOM_cvmix_shear, only : cvmix_shear_is_used use MOM_cvmix_conv, only : cvmix_conv_is_used @@ -85,12 +86,20 @@ module MOM_set_visc !! answers from the end of 2018. Otherwise, use updated and more robust !! forms of the same expressions. logical :: debug !< If true, write verbose checksums for debugging purposes. + logical :: BBL_use_tidal_bg !< If true, use a tidal background amplitude for the bottom velocity + !! when computing the bottom stress + character(len=200) :: inputdir !< The directory for input files. type(ocean_OBC_type), pointer :: OBC => NULL() !< Open boundaries control structure type(diag_ctrl), pointer :: diag => NULL() !< A structure that is used to !! regulate the timing of diagnostic output. + ! Allocatable data arrays + real, allocatable, dimension(:,:) :: tideamp !< RMS tidal amplitude at h points [Z T-1 ~> m s-1] + ! Diagnostic arrays + real, allocatable, dimension(:,:) :: bbl_u !< BBL mean U current [L T-1 ~> m s-1] + real, allocatable, dimension(:,:) :: bbl_v !< BBL mean V current [L T-1 ~> m s-1] !>@{ Diagnostics handles - integer :: id_bbl_thick_u = -1, id_kv_bbl_u = -1 - integer :: id_bbl_thick_v = -1, id_kv_bbl_v = -1 + integer :: id_bbl_thick_u = -1, id_kv_bbl_u = -1, id_bbl_u = -1 + integer :: id_bbl_thick_v = -1, id_kv_bbl_v = -1, id_bbl_v = -1 integer :: id_Ray_u = -1, id_Ray_v = -1 integer :: id_nkml_visc_u = -1, id_nkml_visc_v = -1 !!@} @@ -122,7 +131,7 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, symmetrize) type(vertvisc_type), intent(inout) :: visc !< A structure containing vertical viscosities and !! related fields. type(set_visc_CS), pointer :: CS !< The control structure returned by a previous - !! call to vertvisc_init. + !! call to set_visc_init. logical, optional, intent(in) :: symmetrize !< If present and true, do extra calculations !! of those values in visc that would be !! calculated with symmetric memory. @@ -509,10 +518,18 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, symmetrize) if ((.not.CS%linear_drag) .and. (hweight >= 0.0)) then ; if (m==1) then v_at_u = set_v_at_u(v, h, G, i, j, k, mask_v, OBC) + if (CS%BBL_use_tidal_bg) then + U_bg_sq = 0.5*( G%mask2dT(i,j)*(CS%tideamp(i,j)*CS%tideamp(i,j))+ & + G%mask2dT(i+1,j)*(CS%tideamp(i+1,j)*CS%tideamp(i+1,j)) ) + endif hutot = hutot + hweight * sqrt(u(I,j,k)*u(I,j,k) + & v_at_u*v_at_u + U_bg_sq) else u_at_v = set_u_at_v(u, h, G, i, j, k, mask_u, OBC) + if (CS%BBL_use_tidal_bg) then + U_bg_sq = 0.5*( G%mask2dT(i,j)*(CS%tideamp(i,j)*CS%tideamp(i,j))+ & + G%mask2dT(i,j+1)*(CS%tideamp(i,j+1)*CS%tideamp(i,j+1)) ) + endif hutot = hutot + hweight * sqrt(v(i,J,k)*v(i,J,k) + & u_at_v*u_at_v + U_bg_sq) endif ; endif @@ -534,6 +551,13 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, symmetrize) else T_EOS(i) = 0.0 ; S_EOS(i) = 0.0 endif ; endif + + if (CS%id_bbl_u>0 .and. m==1) then + CS%bbl_u(I,j) = hutot/hwtot + elseif (CS%id_bbl_v>0 .and. m==2) then + CS%bbl_v(i,J) = hutot/hwtot + endif + endif ; enddo else do i=is,ie ; ustar(i) = cdrag_sqrt_Z*CS%drag_bg_vel ; enddo @@ -901,10 +925,14 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, symmetrize) call post_data(CS%id_bbl_thick_u, visc%bbl_thick_u, CS%diag) if (CS%id_kv_bbl_u > 0) & call post_data(CS%id_kv_bbl_u, visc%kv_bbl_u, CS%diag) + if (CS%id_bbl_u > 0) & + call post_data(CS%id_bbl_u, CS%bbl_u, CS%diag) if (CS%id_bbl_thick_v > 0) & call post_data(CS%id_bbl_thick_v, visc%bbl_thick_v, CS%diag) if (CS%id_kv_bbl_v > 0) & call post_data(CS%id_kv_bbl_v, visc%kv_bbl_v, CS%diag) + if (CS%id_bbl_v > 0) & + call post_data(CS%id_bbl_v, CS%bbl_v, CS%diag) if (CS%id_Ray_u > 0) & call post_data(CS%id_Ray_u, visc%Ray_u, CS%diag) if (CS%id_Ray_v > 0) & @@ -1033,7 +1061,7 @@ subroutine set_viscous_ML(u, v, h, tv, forces, visc, dt, G, GV, US, CS, symmetri !! related fields. real, intent(in) :: dt !< Time increment [T ~> s]. type(set_visc_CS), pointer :: CS !< The control structure returned by a previous - !! call to vertvisc_init. + !! call to set_visc_init. logical, optional, intent(in) :: symmetrize !< If present and true, do extra calculations !! of those values in visc that would be !! calculated with symmetric memory. @@ -1809,6 +1837,7 @@ subroutine set_visc_init(Time, G, GV, US, param_file, diag, visc, CS, restart_CS logical :: default_2018_answers logical :: use_kappa_shear, adiabatic, use_omega logical :: use_CVMix_ddiff, differential_diffusion, use_KPP + character(len=200) :: filename, tideamp_file type(OBC_segment_type), pointer :: segment => NULL() ! pointer to OBC segment type ! This include declares and sets the variable "version". # include "version_variable.h" @@ -1833,6 +1862,8 @@ subroutine set_visc_init(Time, G, GV, US, param_file, diag, visc, CS, restart_CS call log_version(param_file, mdl, version, "") CS%RiNo_mix = .false. ; use_CVMix_ddiff = .false. differential_diffusion = .false. + call get_param(param_file, mdl, "INPUTDIR", CS%inputdir, default=".") + CS%inputdir = slasher(CS%inputdir) call get_param(param_file, mdl, "DEFAULT_2018_ANSWERS", default_2018_answers, & "This sets the default value for the various _2018_ANSWERS parameters.", & default=.true.) @@ -1934,12 +1965,23 @@ subroutine set_visc_init(Time, G, GV, US, param_file, diag, visc, CS, restart_CS "the velocity field to the bottom stress. CDRAG is only "//& "used if BOTTOMDRAGLAW is defined.", units="nondim", & default=0.003) - call get_param(param_file, mdl, "DRAG_BG_VEL", CS%drag_bg_vel, & - "DRAG_BG_VEL is either the assumed bottom velocity (with "//& - "LINEAR_DRAG) or an unresolved velocity that is "//& - "combined with the resolved velocity to estimate the "//& - "velocity magnitude. DRAG_BG_VEL is only used when "//& - "BOTTOMDRAGLAW is defined.", units="m s-1", default=0.0, scale=US%m_s_to_L_T) + call get_param(param_file, mdl, "BBL_USE_TIDAL_BG", CS%BBL_use_tidal_bg, & + "Flag to use the tidal RMS amplitude in place of constant "//& + "background velocity for computing u* in the BBL. "//& + "This flag is only used when BOTTOMDRAGLAW is true and "//& + "LINEAR_DRAG is false.", default=.false.) + if (CS%BBL_use_tidal_bg) then + call get_param(param_file, mdl, "TIDEAMP_FILE", tideamp_file, & + "The path to the file containing the spatially varying "//& + "tidal amplitudes with INT_TIDE_DISSIPATION.", default="tideamp.nc") + else + call get_param(param_file, mdl, "DRAG_BG_VEL", CS%drag_bg_vel, & + "DRAG_BG_VEL is either the assumed bottom velocity (with "//& + "LINEAR_DRAG) or an unresolved velocity that is "//& + "combined with the resolved velocity to estimate the "//& + "velocity magnitude. DRAG_BG_VEL is only used when "//& + "BOTTOMDRAGLAW is defined.", units="m s-1", default=0.0, scale=US%m_s_to_L_T) + endif call get_param(param_file, mdl, "BBL_USE_EOS", CS%BBL_use_EOS, & "If true, use the equation of state in determining the "//& "properties of the bottom boundary layer. Otherwise use "//& @@ -2013,10 +2055,20 @@ subroutine set_visc_init(Time, G, GV, US, param_file, diag, visc, CS, restart_CS diag%axesCu1, Time, 'BBL thickness at u points', 'm', conversion=US%Z_to_m) CS%id_kv_bbl_u = register_diag_field('ocean_model', 'kv_bbl_u', diag%axesCu1, & Time, 'BBL viscosity at u points', 'm2 s-1', conversion=US%Z2_T_to_m2_s) + CS%id_bbl_u = register_diag_field('ocean_model', 'bbl_u', diag%axesCu1, & + Time, 'BBL mean u current', 'm s-1', conversion=US%L_T_to_m_s) + if (CS%id_bbl_u>0) then + allocate(CS%bbl_u(IsdB:IedB,jsd:jed)) ; CS%bbl_u = 0.0 + endif CS%id_bbl_thick_v = register_diag_field('ocean_model', 'bbl_thick_v', & diag%axesCv1, Time, 'BBL thickness at v points', 'm', conversion=US%Z_to_m) CS%id_kv_bbl_v = register_diag_field('ocean_model', 'kv_bbl_v', diag%axesCv1, & Time, 'BBL viscosity at v points', 'm2 s-1', conversion=US%Z2_T_to_m2_s) + CS%id_bbl_v = register_diag_field('ocean_model', 'bbl_v', diag%axesCv1, & + Time, 'BBL mean v current', 'm s-1', conversion=US%L_T_to_m_s) + if (CS%id_bbl_v>0) then + allocate(CS%bbl_v(isd:ied,JsdB:JedB)) ; CS%bbl_v = 0.0 + endif endif if (CS%Channel_drag) then allocate(visc%Ray_u(IsdB:IedB,jsd:jed,nz)) ; visc%Ray_u = 0.0 @@ -2041,6 +2093,14 @@ subroutine set_visc_init(Time, G, GV, US, param_file, diag, visc, CS, restart_CS diag%axesCv1, Time, 'Number of layers in viscous mixed layer at v points', 'm') endif + if (CS%BBL_use_tidal_bg) then + allocate(CS%tideamp(isd:ied,jsd:jed)) ; CS%tideamp = 0.0 + filename = trim(CS%inputdir) // trim(tideamp_file) + call log_param(param_file, mdl, "INPUTDIR/TIDEAMP_FILE", filename) + call MOM_read_data(filename, 'tideamp', CS%tideamp, G%domain, timelevel=1, scale=US%m_to_Z*US%T_to_s) + call pass_var(CS%tideamp,G%domain) + endif + call register_restart_field_as_obsolete('Kd_turb','Kd_shear', restart_CS) call register_restart_field_as_obsolete('Kv_turb','Kv_shear', restart_CS) @@ -2082,10 +2142,12 @@ subroutine set_visc_end(visc, CS) type(vertvisc_type), intent(inout) :: visc !< A structure containing vertical viscosities and !! related fields. Elements are deallocated here. type(set_visc_CS), pointer :: CS !< The control structure returned by a previous - !! call to vertvisc_init. + !! call to set_visc_init. if (CS%bottomdraglaw) then deallocate(visc%bbl_thick_u) ; deallocate(visc%bbl_thick_v) deallocate(visc%kv_bbl_u) ; deallocate(visc%kv_bbl_v) + if (allocated(CS%bbl_u)) deallocate(CS%bbl_u) + if (allocated(CS%bbl_v)) deallocate(CS%bbl_v) endif if (CS%Channel_drag) then deallocate(visc%Ray_u) ; deallocate(visc%Ray_v) From 6b9504166865fc51ea4fe3fb4aa4e8dda48e6d1d Mon Sep 17 00:00:00 2001 From: "brandon.reichl" Date: Thu, 23 Jan 2020 09:57:06 -0500 Subject: [PATCH 039/316] Fix potential divide by 0 and adding array syntax --- .../vertical/MOM_set_viscosity.F90 | 34 +++++++++---------- 1 file changed, 17 insertions(+), 17 deletions(-) diff --git a/src/parameterizations/vertical/MOM_set_viscosity.F90 b/src/parameterizations/vertical/MOM_set_viscosity.F90 index faa1bbc7fe..59b7987ea6 100644 --- a/src/parameterizations/vertical/MOM_set_viscosity.F90 +++ b/src/parameterizations/vertical/MOM_set_viscosity.F90 @@ -553,9 +553,9 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, symmetrize) endif ; endif if (CS%id_bbl_u>0 .and. m==1) then - CS%bbl_u(I,j) = hutot/hwtot + if (hwtot > 0.0) CS%bbl_u(I,j) = hutot/hwtot elseif (CS%id_bbl_v>0 .and. m==2) then - CS%bbl_v(i,J) = hutot/hwtot + if (hwtot > 0.0) CS%bbl_v(i,J) = hutot/hwtot endif endif ; enddo @@ -2044,12 +2044,12 @@ subroutine set_visc_init(Time, G, GV, US, param_file, diag, visc, CS, restart_CS endif if (CS%bottomdraglaw) then - allocate(visc%bbl_thick_u(IsdB:IedB,jsd:jed)) ; visc%bbl_thick_u = 0.0 - allocate(visc%kv_bbl_u(IsdB:IedB,jsd:jed)) ; visc%kv_bbl_u = 0.0 - allocate(visc%bbl_thick_v(isd:ied,JsdB:JedB)) ; visc%bbl_thick_v = 0.0 - allocate(visc%kv_bbl_v(isd:ied,JsdB:JedB)) ; visc%kv_bbl_v = 0.0 - allocate(visc%ustar_bbl(isd:ied,jsd:jed)) ; visc%ustar_bbl = 0.0 - allocate(visc%TKE_bbl(isd:ied,jsd:jed)) ; visc%TKE_bbl = 0.0 + allocate(visc%bbl_thick_u(IsdB:IedB,jsd:jed)) ; visc%bbl_thick_u(:,:) = 0.0 + allocate(visc%kv_bbl_u(IsdB:IedB,jsd:jed)) ; visc%kv_bbl_u(:,:) = 0.0 + allocate(visc%bbl_thick_v(isd:ied,JsdB:JedB)) ; visc%bbl_thick_v(:,:) = 0.0 + allocate(visc%kv_bbl_v(isd:ied,JsdB:JedB)) ; visc%kv_bbl_v(:,:) = 0.0 + allocate(visc%ustar_bbl(isd:ied,jsd:jed)) ; visc%ustar_bbl(:,:) = 0.0 + allocate(visc%TKE_bbl(isd:ied,jsd:jed)) ; visc%TKE_bbl(:,:) = 0.0 CS%id_bbl_thick_u = register_diag_field('ocean_model', 'bbl_thick_u', & diag%axesCu1, Time, 'BBL thickness at u points', 'm', conversion=US%Z_to_m) @@ -2058,7 +2058,7 @@ subroutine set_visc_init(Time, G, GV, US, param_file, diag, visc, CS, restart_CS CS%id_bbl_u = register_diag_field('ocean_model', 'bbl_u', diag%axesCu1, & Time, 'BBL mean u current', 'm s-1', conversion=US%L_T_to_m_s) if (CS%id_bbl_u>0) then - allocate(CS%bbl_u(IsdB:IedB,jsd:jed)) ; CS%bbl_u = 0.0 + allocate(CS%bbl_u(IsdB:IedB,jsd:jed)) ; CS%bbl_u(:,:) = 0.0 endif CS%id_bbl_thick_v = register_diag_field('ocean_model', 'bbl_thick_v', & diag%axesCv1, Time, 'BBL thickness at v points', 'm', conversion=US%Z_to_m) @@ -2067,12 +2067,12 @@ subroutine set_visc_init(Time, G, GV, US, param_file, diag, visc, CS, restart_CS CS%id_bbl_v = register_diag_field('ocean_model', 'bbl_v', diag%axesCv1, & Time, 'BBL mean v current', 'm s-1', conversion=US%L_T_to_m_s) if (CS%id_bbl_v>0) then - allocate(CS%bbl_v(isd:ied,JsdB:JedB)) ; CS%bbl_v = 0.0 + allocate(CS%bbl_v(isd:ied,JsdB:JedB)) ; CS%bbl_v(:,:) = 0.0 endif endif if (CS%Channel_drag) then - allocate(visc%Ray_u(IsdB:IedB,jsd:jed,nz)) ; visc%Ray_u = 0.0 - allocate(visc%Ray_v(isd:ied,JsdB:JedB,nz)) ; visc%Ray_v = 0.0 + allocate(visc%Ray_u(IsdB:IedB,jsd:jed,nz)) ; visc%Ray_u(:,:,:) = 0.0 + allocate(visc%Ray_v(isd:ied,JsdB:JedB,nz)) ; visc%Ray_v(:,:,:) = 0.0 CS%id_Ray_u = register_diag_field('ocean_model', 'Rayleigh_u', diag%axesCuL, & Time, 'Rayleigh drag velocity at u points', 'm s-1', conversion=US%Z_to_m*US%s_to_T) CS%id_Ray_v = register_diag_field('ocean_model', 'Rayleigh_v', diag%axesCvL, & @@ -2080,13 +2080,13 @@ subroutine set_visc_init(Time, G, GV, US, param_file, diag, visc, CS, restart_CS endif 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 + 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 if (CS%dynamic_viscous_ML) then - allocate(visc%nkml_visc_u(IsdB:IedB,jsd:jed)) ; visc%nkml_visc_u = 0.0 - allocate(visc%nkml_visc_v(isd:ied,JsdB:JedB)) ; visc%nkml_visc_v = 0.0 + allocate(visc%nkml_visc_u(IsdB:IedB,jsd:jed)) ; visc%nkml_visc_u(:,:) = 0.0 + allocate(visc%nkml_visc_v(isd:ied,JsdB:JedB)) ; visc%nkml_visc_v(:,:) = 0.0 CS%id_nkml_visc_u = register_diag_field('ocean_model', 'nkml_visc_u', & diag%axesCu1, Time, 'Number of layers in viscous mixed layer at u points', 'm') CS%id_nkml_visc_v = register_diag_field('ocean_model', 'nkml_visc_v', & @@ -2094,7 +2094,7 @@ subroutine set_visc_init(Time, G, GV, US, param_file, diag, visc, CS, restart_CS endif if (CS%BBL_use_tidal_bg) then - allocate(CS%tideamp(isd:ied,jsd:jed)) ; CS%tideamp = 0.0 + allocate(CS%tideamp(isd:ied,jsd:jed)) ; CS%tideamp(:,:) = 0.0 filename = trim(CS%inputdir) // trim(tideamp_file) call log_param(param_file, mdl, "INPUTDIR/TIDEAMP_FILE", filename) call MOM_read_data(filename, 'tideamp', CS%tideamp, G%domain, timelevel=1, scale=US%m_to_Z*US%T_to_s) From 00d1b6a116d34695e6e2ad1ce6291fed37769c2c Mon Sep 17 00:00:00 2001 From: "brandon.reichl" Date: Thu, 23 Jan 2020 10:04:34 -0500 Subject: [PATCH 040/316] Moving BBL_USE_TIDAL_BG loop inside bottomdraglaw loop --- .../vertical/MOM_set_viscosity.F90 | 15 +++++++-------- 1 file changed, 7 insertions(+), 8 deletions(-) diff --git a/src/parameterizations/vertical/MOM_set_viscosity.F90 b/src/parameterizations/vertical/MOM_set_viscosity.F90 index 59b7987ea6..7019a3e379 100644 --- a/src/parameterizations/vertical/MOM_set_viscosity.F90 +++ b/src/parameterizations/vertical/MOM_set_viscosity.F90 @@ -2069,6 +2069,13 @@ subroutine set_visc_init(Time, G, GV, US, param_file, diag, visc, CS, restart_CS if (CS%id_bbl_v>0) then allocate(CS%bbl_v(isd:ied,JsdB:JedB)) ; CS%bbl_v(:,:) = 0.0 endif + if (CS%BBL_use_tidal_bg) then + allocate(CS%tideamp(isd:ied,jsd:jed)) ; CS%tideamp(:,:) = 0.0 + filename = trim(CS%inputdir) // trim(tideamp_file) + call log_param(param_file, mdl, "INPUTDIR/TIDEAMP_FILE", filename) + call MOM_read_data(filename, 'tideamp', CS%tideamp, G%domain, timelevel=1, scale=US%m_to_Z*US%T_to_s) + call pass_var(CS%tideamp,G%domain) + endif endif if (CS%Channel_drag) then allocate(visc%Ray_u(IsdB:IedB,jsd:jed,nz)) ; visc%Ray_u(:,:,:) = 0.0 @@ -2093,14 +2100,6 @@ subroutine set_visc_init(Time, G, GV, US, param_file, diag, visc, CS, restart_CS diag%axesCv1, Time, 'Number of layers in viscous mixed layer at v points', 'm') endif - if (CS%BBL_use_tidal_bg) then - allocate(CS%tideamp(isd:ied,jsd:jed)) ; CS%tideamp(:,:) = 0.0 - filename = trim(CS%inputdir) // trim(tideamp_file) - call log_param(param_file, mdl, "INPUTDIR/TIDEAMP_FILE", filename) - call MOM_read_data(filename, 'tideamp', CS%tideamp, G%domain, timelevel=1, scale=US%m_to_Z*US%T_to_s) - call pass_var(CS%tideamp,G%domain) - endif - call register_restart_field_as_obsolete('Kd_turb','Kd_shear', restart_CS) call register_restart_field_as_obsolete('Kv_turb','Kv_shear', restart_CS) From 3a99531760646de1bb94213f611aa6400581e087 Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Thu, 23 Jan 2020 18:45:14 +0000 Subject: [PATCH 041/316] Added option to trailer.py for line length excluding comments - Option -s now specifies the maximum length of lines after stripping out comments. The defaults are for the Fortran standard, not MOM6. MOM6 standard are specified in the Travis-CI invocation of trailer.py. --- .testing/trailer.py | 9 +++++++-- 1 file changed, 7 insertions(+), 2 deletions(-) diff --git a/.testing/trailer.py b/.testing/trailer.py index 80b7e72738..a483bf9995 100755 --- a/.testing/trailer.py +++ b/.testing/trailer.py @@ -22,6 +22,8 @@ def parseCommandLine(): help='''Exclude directories from search that end in DIR.''') parser.add_argument('-l','--line_length', type=int, default=512, help='''Maximum allowed length of a line.''') + parser.add_argument('-s','--source_line_length', type=int, default=132, + help='''Maximum allowed length of a source line excluding comments.''') parser.add_argument('-d','--debug', action='store_true', help='turn on debugging information.') args = parser.parse_args() @@ -57,11 +59,11 @@ def main(args): # For each file, check for trailing white space fail = False for filename in all_files: - this = scan_file(filename, line_length=args.line_length) + this = scan_file(filename, line_length=args.line_length, source_line_length=args.source_line_length) fail = fail or this if fail: sys.exit(1) -def scan_file(filename, line_length=120): +def scan_file(filename, line_length=512, source_line_length=132): '''Scans file for trailing white space''' def msg(filename,lineno,mesg,line=None): if line is None: print('%s, line %i: %s'%(filename,lineno,mesg)) @@ -76,6 +78,7 @@ def msg(filename,lineno,mesg,line=None): for line in file.readlines(): lineno += 1 line = line.replace('\n','') + srcline = line.split('!', 1)[0] # Discard comments if trailing_space.match(line) is not None: if debug: print(filename,lineno,line,trailing_space.match(line)) if len(line.strip())>0: msg(filename,lineno,'Trailing space detected',line) @@ -89,6 +92,8 @@ def msg(filename,lineno,mesg,line=None): if len(line.strip())>0: msg(filename,lineno,'Line length exceeded',line) else: msg(filename,lineno,'Blank line exceeds line length limit') long_line_detected = True + if len(srcline)>source_line_length: + msg(filename,lineno,'Non-comment line length exceeded',line) return white_space_detected or tabs_space_detected or long_line_detected # Invoke parseCommandLine(), the top-level procedure From 4ce3ffc87e267bd86d51f58eb1ec8025f476a261 Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Sat, 25 Jan 2020 18:37:39 +0000 Subject: [PATCH 042/316] Replaced intent(out) with intent(inout) in EOS - For arrays using intent(inout) avoids potential copies and also allows aliasing of arguments which can reduce the overhead of multiple spare arrays in the calling code. --- src/equation_of_state/MOM_EOS.F90 | 201 +++++++++++------------ src/equation_of_state/MOM_EOS_Wright.F90 | 110 ++++++------- 2 files changed, 155 insertions(+), 156 deletions(-) diff --git a/src/equation_of_state/MOM_EOS.F90 b/src/equation_of_state/MOM_EOS.F90 index 5d3d33534b..3d0cb9abc4 100644 --- a/src/equation_of_state/MOM_EOS.F90 +++ b/src/equation_of_state/MOM_EOS.F90 @@ -136,14 +136,14 @@ module MOM_EOS !> Calls the appropriate subroutine to calculate density of sea water for scalar inputs. !! 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, scale) - real, intent(in) :: T !< Potential temperature referenced to the surface [degC] - real, intent(in) :: S !< Salinity [ppt] + real, intent(in) :: T !< Potential temperature referenced to the surface [degC] + real, intent(in) :: S !< Salinity [ppt] real, intent(in) :: pressure !< Pressure [Pa] - real, intent(out) :: rho !< Density (in-situ if pressure is local) [kg m-3] or [R ~> kg m-3] - type(EOS_type), pointer :: EOS !< Equation of state structure + real, intent(out) :: rho !< Density (in-situ if pressure is local) [kg m-3] or [R ~> kg m-3] + type(EOS_type), pointer :: EOS !< Equation of state structure real, optional, intent(in) :: rho_ref !< A reference density [kg m-3]. - real, optional, intent(in) :: scale !< A multiplicative factor by which to scale density - !! from kg m-3 to the desired units [R m3 kg-1] + real, optional, intent(in) :: scale !< A multiplicative factor by which to scale density + !! from kg m-3 to the desired units [R m3 kg-1] if (.not.associated(EOS)) call MOM_error(FATAL, & "calculate_density_scalar called with an unassociated EOS_type EOS.") @@ -174,16 +174,16 @@ end subroutine calculate_density_scalar !> Calls the appropriate subroutine to calculate the density of sea water for 1-D array inputs. !! 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, scale) - real, dimension(:), intent(in) :: T !< Potential temperature referenced to the surface [degC] - real, dimension(:), intent(in) :: S !< Salinity [ppt] - real, dimension(:), intent(in) :: pressure !< Pressure [Pa] - real, dimension(:), intent(out) :: rho !< Density (in-situ if pressure is local) [kg m-3] or [R ~> kg m-3] - 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 [kg m-3]. - real, optional, intent(in) :: scale !< A multiplicative factor by which to scale density - !! from kg m-3 to the desired units [R m3 kg-1] + real, dimension(:), intent(in) :: T !< Potential temperature referenced to the surface [degC] + real, dimension(:), intent(in) :: S !< Salinity [ppt] + real, dimension(:), intent(in) :: pressure !< Pressure [Pa] + real, dimension(:), intent(inout) :: rho !< Density (in-situ if pressure is local) [kg m-3] or [R ~> kg m-3] + 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 [kg m-3]. + real, optional, intent(in) :: scale !< A multiplicative factor by which to scale density + !! from kg m-3 to the desired units [R m3 kg-1] integer :: j if (.not.associated(EOS)) call MOM_error(FATAL, & @@ -215,14 +215,14 @@ 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, scale) - real, intent(in) :: T !< Potential temperature referenced to the surface [degC] - real, intent(in) :: S !< Salinity [ppt] + real, intent(in) :: T !< Potential temperature referenced to the surface [degC] + real, intent(in) :: S !< Salinity [ppt] real, intent(in) :: pressure !< Pressure [Pa] real, intent(out) :: specvol !< In situ? specific volume [m3 kg-1] or [R-1 ~> m3 kg-1] type(EOS_type), pointer :: EOS !< Equation of state structure real, optional, intent(in) :: spv_ref !< A reference specific volume [m3 kg-1]. - real, optional, intent(in) :: scale !< A multiplicative factor by which to scale specific volume - !! from m3 kg-1 to the desired units [kg m-3 R-1] + real, optional, intent(in) :: scale !< A multiplicative factor by which to scale specific + !! volume from m3 kg-1 to the desired units [kg m-3 R-1] real :: rho @@ -261,17 +261,16 @@ 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, scale) - real, dimension(:), intent(in) :: T !< potential temperature relative to the surface - !! [degC]. - real, dimension(:), intent(in) :: S !< salinity [ppt]. - real, dimension(:), intent(in) :: pressure !< pressure [Pa]. - real, dimension(:), intent(out) :: specvol !< in situ specific volume [kg m-3] or [R-1 ~> m3 kg-1]. - 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 [m3 kg-1]. - real, optional, intent(in) :: scale !< A multiplicative factor by which to scale specific volume - !! from m3 kg-1 to the desired units [kg m-3 R-1] + real, dimension(:), intent(in) :: T !< potential temperature relative to the surface [degC]. + real, dimension(:), intent(in) :: S !< salinity [ppt]. + real, dimension(:), intent(in) :: pressure !< pressure [Pa]. + real, dimension(:), intent(inout) :: specvol !< in situ specific volume [kg m-3] or [R-1 ~> m3 kg-1]. + 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 [m3 kg-1]. + real, optional, intent(in) :: scale !< A multiplicative factor by which to scale specific volume + !! from m3 kg-1 to the desired units [kg m-3 R-1] real, dimension(size(specvol)) :: rho integer :: j @@ -336,13 +335,13 @@ end subroutine calculate_TFreeze_scalar !> Calls the appropriate subroutine to calculate the freezing point for a 1-D array. subroutine calculate_TFreeze_array(S, pressure, T_fr, start, npts, EOS) - real, dimension(:), intent(in) :: S !< Salinity [ppt] - real, dimension(:), intent(in) :: pressure !< Pressure [Pa] - 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 + real, dimension(:), intent(in) :: S !< Salinity [ppt] + real, dimension(:), intent(in) :: pressure !< Pressure [Pa] + real, dimension(:), intent(inout) :: 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 if (.not.associated(EOS)) call MOM_error(FATAL, & "calculate_TFreeze_scalar called with an unassociated EOS_type EOS.") @@ -364,18 +363,18 @@ end subroutine calculate_TFreeze_array !> Calls the appropriate subroutine to calculate density derivatives for 1-D array inputs. subroutine calculate_density_derivs_array(T, S, pressure, drho_dT, drho_dS, start, npts, EOS, scale) - real, dimension(:), intent(in) :: T !< Potential temperature referenced to the surface [degC] - real, dimension(:), intent(in) :: S !< Salinity [ppt] - real, dimension(:), intent(in) :: pressure !< Pressure [Pa] - real, dimension(:), intent(out) :: drho_dT !< The partial derivative of density with potential - !! temperature [kg m-3 degC-1] or [R degC-1 ~> kg m-3 degC-1]. - real, dimension(:), intent(out) :: drho_dS !< The partial derivative of density with salinity, - !! in [kg m-3 ppt-1] or [R degC-1 ~> kg m-3 ppt-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 - real, optional, intent(in) :: scale !< A multiplicative factor by which to scale density - !! from kg m-3 to the desired units [R m3 kg-1] + real, dimension(:), intent(in) :: T !< Potential temperature referenced to the surface [degC] + real, dimension(:), intent(in) :: S !< Salinity [ppt] + real, dimension(:), intent(in) :: pressure !< Pressure [Pa] + real, dimension(:), intent(inout) :: drho_dT !< The partial derivative of density with potential + !! temperature [kg m-3 degC-1] or [R degC-1 ~> kg m-3 degC-1]. + real, dimension(:), intent(inout) :: drho_dS !< The partial derivative of density with salinity, + !! in [kg m-3 ppt-1] or [R degC-1 ~> kg m-3 ppt-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 + real, optional, intent(in) :: scale !< A multiplicative factor by which to scale density + !! from kg m-3 to the desired units [R m3 kg-1] integer :: j if (.not.associated(EOS)) call MOM_error(FATAL, & @@ -448,16 +447,16 @@ subroutine calculate_density_second_derivs_array(T, S, pressure, drho_dS_dS, drh real, dimension(:), intent(in) :: T !< Potential temperature referenced to the surface [degC] real, dimension(:), intent(in) :: S !< Salinity [ppt] real, dimension(:), intent(in) :: pressure !< Pressure [Pa] - real, dimension(:), intent(out) :: drho_dS_dS !< Partial derivative of beta with respect to S - !! [kg m-3 ppt-2] or [R ppt-2 ~> kg m-3 ppt-2] - real, dimension(:), intent(out) :: drho_dS_dT !< Partial derivative of beta with respect to T - !! [kg m-3 ppt-1 degC-1] or [R ppt-1 degC-1 ~> kg m-3 ppt-1 degC-1] - real, dimension(:), intent(out) :: drho_dT_dT !< Partial derivative of alpha with respect to T - !! [kg m-3 degC-2] or [R degC-2 ~> kg m-3 degC-2] - real, dimension(:), intent(out) :: drho_dS_dP !< Partial derivative of beta with respect to pressure - !! [kg m-3 ppt-1 Pa-1] or [R ppt-1 Pa-1 ~> kg m-3 ppt-1 Pa-1] - real, dimension(:), intent(out) :: drho_dT_dP !< Partial derivative of alpha with respect to pressure - !! [kg m-3 degC-1 Pa-1] or [R degC-1 Pa-1 ~> kg m-3 degC-1 Pa-1] + real, dimension(:), intent(inout) :: drho_dS_dS !< Partial derivative of beta with respect to S + !! [kg m-3 ppt-2] or [R ppt-2 ~> kg m-3 ppt-2] + real, dimension(:), intent(inout) :: drho_dS_dT !< Partial derivative of beta with respect to T + !! [kg m-3 ppt-1 degC-1] or [R ppt-1 degC-1 ~> kg m-3 ppt-1 degC-1] + real, dimension(:), intent(inout) :: drho_dT_dT !< Partial derivative of alpha with respect to T + !! [kg m-3 degC-2] or [R degC-2 ~> kg m-3 degC-2] + real, dimension(:), intent(inout) :: drho_dS_dP !< Partial derivative of beta with respect to pressure + !! [kg m-3 ppt-1 Pa-1] or [R ppt-1 Pa-1 ~> kg m-3 ppt-1 Pa-1] + real, dimension(:), intent(inout) :: drho_dT_dP !< Partial derivative of alpha with respect to pressure + !! [kg m-3 degC-1 Pa-1] or [R degC-1 Pa-1 ~> kg m-3 degC-1 Pa-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 @@ -546,10 +545,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 [ppt] real, dimension(:), intent(in) :: pressure !< Pressure [Pa] - real, dimension(:), intent(out) :: dSV_dT !< The partial derivative of specific volume with potential - !! temperature [m3 kg-1 degC-1] or [R-1 degC-1 ~> m3 kg-1 degC-1] - real, dimension(:), intent(out) :: dSV_dS !< The partial derivative of specific volume with salinity - !! [m3 kg-1 ppt-1] or [R-1 ppt-1 ~> m3 kg-1 ppt-1]. + real, dimension(:), intent(inout) :: dSV_dT !< The partial derivative of specific volume with potential + !! temperature [m3 kg-1 degC-1] or [R-1 degC-1 ~> m3 kg-1 degC-1] + real, dimension(:), intent(inout) :: dSV_dS !< The partial derivative of specific volume with salinity + !! [m3 kg-1 ppt-1] or [R-1 ppt-1 ~> m3 kg-1 ppt-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 @@ -603,9 +602,9 @@ subroutine calculate_compress_array(T, S, pressure, rho, drho_dp, start, npts, E 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) :: rho !< In situ density [kg m-3]. - real, dimension(:), intent(out) :: drho_dp !< The partial derivative of density with pressure - !! (also the inverse of the square of sound speed) [s2 m-2]. + real, dimension(:), intent(inout) :: rho !< In situ density [kg m-3]. + real, dimension(:), intent(inout) :: drho_dp !< The partial derivative of density with pressure + !! (also the inverse of the square of sound speed) [s2 m-2]. 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 @@ -677,18 +676,18 @@ subroutine int_specific_vol_dp(T, S, p_t, p_b, alpha_ref, HI, EOS, & !! alpha_ref, but this reduces the effects of roundoff. 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 + intent(inout) :: dza !< The change in the geopotential anomaly across !! the layer [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 + optional, intent(inout) :: intp_dza !< The integral in pressure through the layer of the !! geopotential anomaly relative to the anomaly at the bottom of the !! layer [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 + optional, intent(inout) :: 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 [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 + optional, intent(inout) :: 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 [m2 s-2]. integer, optional, intent(in) :: halo_size !< The width of halo points on which to calculate dza. @@ -747,17 +746,17 @@ subroutine int_density_dz(T, S, z_t, z_b, rho_ref, rho_0, G_e, HII, HIO, EOS, & real, intent(in) :: G_e !< The Earth's gravitational acceleration [m2 Z-1 s-2 ~> 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 !< The change in the pressure anomaly across the layer [Pa]. + intent(inout) :: dpa !< The change in the pressure anomaly across the layer [Pa]. real, dimension(HIO%isd:HIO%ied,HIO%jsd:HIO%jed), & - optional, intent(out) :: intz_dpa !< The integral through the thickness of the layer of + optional, intent(inout) :: intz_dpa !< The integral through the thickness of the layer of !! the pressure anomaly relative to the anomaly at the !! top of the layer [Pa Z ~> Pa m]. real, dimension(HIO%IsdB:HIO%IedB,HIO%jsd:HIO%jed), & - optional, intent(out) :: intx_dpa !< The integral in x of the difference between the + optional, intent(inout) :: 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 [Pa]. real, dimension(HIO%isd:HIO%ied,HIO%JsdB:HIO%JedB), & - optional, intent(out) :: inty_dpa !< The integral in y of the difference between the + optional, intent(inout) :: 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 [Pa]. real, dimension(HII%isd:HII%ied,HII%jsd:HII%jed), & @@ -1000,18 +999,18 @@ subroutine int_density_dz_generic(T, S, z_t, z_b, rho_ref, rho_0, G_e, HII, HIO, real, intent(in) :: G_e !< The Earth's gravitational acceleration [m2 Z-1 s-2 ~> 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 !< The change in the pressure anomaly + intent(inout) :: dpa !< The change in the pressure anomaly !! across the layer [Pa]. real, dimension(HIO%isd:HIO%ied,HIO%jsd:HIO%jed), & - optional, intent(out) :: intz_dpa !< The integral through the thickness of the + optional, intent(inout) :: intz_dpa !< The integral through the thickness of the !! layer of the pressure anomaly relative to the !! anomaly at the top of the layer [Pa Z ~> Pa m]. real, dimension(HIO%IsdB:HIO%IedB,HIO%jsd:HIO%jed), & - optional, intent(out) :: intx_dpa !< The integral in x of the difference between + optional, intent(inout) :: 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 [Pa]. real, dimension(HIO%isd:HIO%ied,HIO%JsdB:HIO%JedB), & - optional, intent(out) :: inty_dpa !< The integral in y of the difference between + optional, intent(inout) :: 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 [Pa]. real, dimension(HII%isd:HII%ied,HII%jsd:HII%jed), & @@ -1193,17 +1192,17 @@ subroutine int_density_dz_generic_plm (T_t, T_b, S_t, S_b, z_t, z_b, rho_ref, & intent(in) :: bathyT !< The depth of the bathymetry [Z ~> m]. type(EOS_type), pointer :: EOS !< Equation of state structure real, dimension(HIO%isd:HIO%ied,HIO%jsd:HIO%jed), & - intent(out) :: dpa !< The change in the pressure anomaly across the layer [Pa]. + intent(inout) :: dpa !< The change in the pressure anomaly across the layer [Pa]. real, dimension(HIO%isd:HIO%ied,HIO%jsd:HIO%jed), & - optional, intent(out) :: intz_dpa !< The integral through the thickness of the layer of + optional, intent(inout) :: intz_dpa !< The integral through the thickness of the layer of !! the pressure anomaly relative to the anomaly at the !! top of the layer [Pa Z]. real, dimension(HIO%IsdB:HIO%IedB,HIO%jsd:HIO%jed), & - optional, intent(out) :: intx_dpa !< The integral in x of the difference between the + optional, intent(inout) :: 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 [Pa]. real, dimension(HIO%isd:HIO%ied,HIO%JsdB:HIO%JedB), & - optional, intent(out) :: inty_dpa !< The integral in y of the difference between the + optional, intent(inout) :: 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 [Pa]. logical, optional, intent(in) :: useMassWghtInterp !< If true, uses mass weighting to @@ -1608,17 +1607,17 @@ subroutine int_density_dz_generic_ppm (T, T_t, T_b, S, S_t, S_b, & real, intent(in) :: G_e !< The Earth's gravitational acceleration [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 !< The change in the pressure anomaly across the layer [Pa]. + intent(inout) :: dpa !< The change in the pressure anomaly across the layer [Pa]. real, dimension(HIO%isd:HIO%ied,HIO%jsd:HIO%jed), & - optional, intent(out) :: intz_dpa !< The integral through the thickness of the layer of + optional, intent(inout) :: intz_dpa !< The integral through the thickness of the layer of !! the pressure anomaly relative to the anomaly at the !! top of the layer [Pa Z ~> Pa m]. real, dimension(HIO%IsdB:HIO%IedB,HIO%jsd:HIO%jed), & - optional, intent(out) :: intx_dpa !< The integral in x of the difference between the + optional, intent(inout) :: 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 [Pa]. real, dimension(HIO%isd:HIO%ied,HIO%JsdB:HIO%JedB), & - optional, intent(out) :: inty_dpa !< The integral in y of the difference between the + optional, intent(inout) :: 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 [Pa]. @@ -1916,10 +1915,10 @@ end subroutine compute_integral_quadratic subroutine evaluate_shape_bilinear( xi, eta, phi, dphidxi, dphideta ) real, intent(in) :: xi !< The x position to evaluate real, intent(in) :: eta !< The z position to evaluate - real, dimension(4), intent(out) :: phi !< The weights of the four corners at this point - real, dimension(4), intent(out) :: dphidxi !< The x-gradient of the weights of the four + real, dimension(4), intent(inout) :: phi !< The weights of the four corners at this point + real, dimension(4), intent(inout) :: dphidxi !< The x-gradient of the weights of the four !! corners at this point - real, dimension(4), intent(out) :: dphideta !< The z-gradient of the weights of the four + real, dimension(4), intent(inout) :: dphideta !< The z-gradient of the weights of the four !! corners at this point ! The shape functions within the parent element are defined as shown here: @@ -1957,11 +1956,11 @@ subroutine evaluate_shape_quadratic ( xi, eta, phi, dphidxi, dphideta ) ! Arguments real, intent(in) :: xi !< The x position to evaluate real, intent(in) :: eta !< The z position to evaluate - real, dimension(9), intent(out) :: phi !< The weights of the 9 bilinear quadrature points + real, dimension(9), intent(inout) :: phi !< The weights of the 9 bilinear quadrature points !! at this point - real, dimension(9), intent(out) :: dphidxi !< The x-gradient of the weights of the 9 bilinear + real, dimension(9), intent(inout) :: dphidxi !< The x-gradient of the weights of the 9 bilinear !! quadrature points corners at this point - real, dimension(9), intent(out) :: dphideta !< The z-gradient of the weights of the 9 bilinear + real, dimension(9), intent(inout) :: dphideta !< The z-gradient of the weights of the 9 bilinear !! quadrature points corners at this point ! The quadratic shape functions within the parent element are defined as shown here: @@ -2037,18 +2036,18 @@ subroutine int_spec_vol_dp_generic(T, S, p_t, p_b, alpha_ref, HI, EOS, & !! 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 !< The change in the geopotential anomaly + intent(inout) :: dza !< The change in the geopotential anomaly !! across the layer [m2 s-2]. real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & - optional, intent(out) :: intp_dza !< The integral in pressure through the + optional, intent(inout) :: intp_dza !< The integral in pressure through the !! layer of the geopotential anomaly relative to the anomaly !! at the bottom of the layer [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 + optional, intent(inout) :: 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 [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 + optional, intent(inout) :: 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 [m2 s-2]. integer, optional, intent(in) :: halo_size !< The width of halo points on which to calculate dza. @@ -2235,18 +2234,18 @@ subroutine int_spec_vol_dp_generic_plm(T_t, T_b, S_t, S_b, p_t, p_b, alpha_ref, intent(in) :: bathyP !< The pressure at the bathymetry [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 + intent(inout) :: dza !< The change in the geopotential anomaly !! across the layer [m2 s-2]. real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & - optional, intent(out) :: intp_dza !< The integral in pressure through the + optional, intent(inout) :: intp_dza !< The integral in pressure through the !! layer of the geopotential anomaly relative to the anomaly !! at the bottom of the layer [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 + optional, intent(inout) :: 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 [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 + optional, intent(inout) :: 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 [m2 s-2]. logical, optional, intent(in) :: useMassWghtInterp !< If true, uses mass weighting diff --git a/src/equation_of_state/MOM_EOS_Wright.F90 b/src/equation_of_state/MOM_EOS_Wright.F90 index 899f32b27d..8d29e08f92 100644 --- a/src/equation_of_state/MOM_EOS_Wright.F90 +++ b/src/equation_of_state/MOM_EOS_Wright.F90 @@ -108,13 +108,13 @@ end subroutine calculate_density_scalar_wright !! (T [degC]), and pressure [Pa]. It uses the expression from !! Wright, 1997, J. Atmos. Ocean. Tech., 14, 735-740. subroutine calculate_density_array_wright(T, S, pressure, rho, start, npts, rho_ref) - real, dimension(:), intent(in) :: T !< potential temperature relative to the surface [degC]. - real, dimension(:), intent(in) :: S !< salinity [PSU]. - real, dimension(:), intent(in) :: pressure !< pressure [Pa]. - real, dimension(:), intent(out) :: rho !< in situ density [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 [kg m-3]. + real, dimension(:), intent(in) :: T !< potential temperature relative to the surface [degC]. + real, dimension(:), intent(in) :: S !< salinity [PSU]. + real, dimension(:), intent(in) :: pressure !< pressure [Pa]. + real, dimension(:), intent(inout) :: rho !< in situ density [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 [kg m-3]. ! Original coded by R. Hallberg, 7/00, anomaly coded in 3/18. ! Local variables @@ -169,14 +169,14 @@ end subroutine calculate_spec_vol_scalar_wright !! 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 + real, dimension(:), intent(in) :: T !< potential temperature relative to the !! surface [degC]. - real, dimension(:), intent(in) :: S !< salinity [PSU]. - real, dimension(:), intent(in) :: pressure !< pressure [Pa]. - real, dimension(:), intent(out) :: specvol !< in situ specific volume [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 [m3 kg-1]. + real, dimension(:), intent(in) :: S !< salinity [PSU]. + real, dimension(:), intent(in) :: pressure !< pressure [Pa]. + real, dimension(:), intent(inout) :: specvol !< in situ specific volume [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 [m3 kg-1]. ! Local variables real :: al0, p0, lambda @@ -197,16 +197,16 @@ 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) - real, intent(in), dimension(:) :: T !< Potential temperature relative to the - !! surface [degC]. - real, intent(in), dimension(:) :: S !< Salinity [PSU]. - real, intent(in), dimension(:) :: pressure !< pressure [Pa]. - real, intent(out), dimension(:) :: drho_dT !< The partial derivative of density with potential - !! temperature [kg m-3 degC-1]. - real, intent(out), dimension(:) :: drho_dS !< The partial derivative of density with salinity, - !! in [kg m-3 PSU-1]. - integer, intent(in) :: start !< The starting point in the arrays. - integer, intent(in) :: npts !< The number of values to calculate. + real, intent(in), dimension(:) :: T !< Potential temperature relative to the + !! surface [degC]. + real, intent(in), dimension(:) :: S !< Salinity [PSU]. + real, intent(in), dimension(:) :: pressure !< pressure [Pa]. + real, intent(inout), dimension(:) :: drho_dT !< The partial derivative of density with potential + !! temperature [kg m-3 degC-1]. + real, intent(inout), dimension(:) :: drho_dS !< The partial derivative of density with salinity, + !! in [kg m-3 PSU-1]. + integer, intent(in) :: start !< The starting point in the arrays. + integer, intent(in) :: npts !< The number of values to calculate. ! Local variables real :: al0, p0, lambda, I_denom2 @@ -259,15 +259,15 @@ subroutine calculate_density_second_derivs_array_wright(T, S, P, drho_ds_ds, drh real, dimension(:), intent(in ) :: T !< Potential temperature referenced to 0 dbar [degC] real, dimension(:), intent(in ) :: S !< Salinity [PSU] real, dimension(:), intent(in ) :: P !< Pressure [Pa] - real, dimension(:), intent( out) :: drho_ds_ds !< Partial derivative of beta with respect + real, dimension(:), intent(inout) :: drho_ds_ds !< Partial derivative of beta with respect !! to S [kg m-3 PSU-2] - real, dimension(:), intent( out) :: drho_ds_dt !< Partial derivative of beta with respcct + real, dimension(:), intent(inout) :: drho_ds_dt !< Partial derivative of beta with respcct !! to T [kg m-3 PSU-1 degC-1] - real, dimension(:), intent( out) :: drho_dt_dt !< Partial derivative of alpha with respect + real, dimension(:), intent(inout) :: drho_dt_dt !< Partial derivative of alpha with respect !! to T [kg m-3 degC-2] - real, dimension(:), intent( out) :: drho_ds_dp !< Partial derivative of beta with respect + real, dimension(:), intent(inout) :: drho_ds_dp !< Partial derivative of beta with respect !! to pressure [kg m-3 PSU-1 Pa-1] - real, dimension(:), intent( out) :: drho_dt_dp !< Partial derivative of alpha with respect + real, dimension(:), intent(inout) :: drho_dt_dp !< Partial derivative of alpha with respect !! to pressure [kg m-3 degC-1 Pa-1] integer, intent(in ) :: start !< Starting index in T,S,P integer, intent(in ) :: npts !< Number of points to loop over @@ -340,15 +340,15 @@ end subroutine calculate_density_second_derivs_scalar_wright !> For a given thermodynamic state, return the partial derivatives of specific volume !! with temperature and salinity subroutine calculate_specvol_derivs_wright(T, S, pressure, dSV_dT, dSV_dS, start, npts) - real, intent(in), dimension(:) :: T !< Potential temperature relative to the surface [degC]. - real, intent(in), dimension(:) :: S !< Salinity [PSU]. - real, intent(in), dimension(:) :: pressure !< pressure [Pa]. - real, intent(out), dimension(:) :: dSV_dT !< The partial derivative of specific volume with - !! potential temperature [m3 kg-1 degC-1]. - real, intent(out), dimension(:) :: dSV_dS !< The partial derivative of specific volume with - !! salinity [m3 kg-1 / Pa]. - integer, intent(in) :: start !< The starting point in the arrays. - integer, intent(in) :: npts !< The number of values to calculate. + real, intent(in), dimension(:) :: T !< Potential temperature relative to the surface [degC]. + real, intent(in), dimension(:) :: S !< Salinity [PSU]. + real, intent(in), dimension(:) :: pressure !< pressure [Pa]. + real, intent(inout), dimension(:) :: dSV_dT !< The partial derivative of specific volume with + !! potential temperature [m3 kg-1 degC-1]. + real, intent(inout), dimension(:) :: dSV_dS !< The partial derivative of specific volume with + !! salinity [m3 kg-1 / Pa]. + integer, intent(in) :: start !< The starting point in the arrays. + integer, intent(in) :: npts !< The number of values to calculate. ! Local variables real :: al0, p0, lambda, I_denom @@ -377,15 +377,15 @@ end subroutine calculate_specvol_derivs_wright !! from Wright, 1997, J. Atmos. Ocean. Tech., 14, 735-740. !! Coded by R. Hallberg, 1/01 subroutine calculate_compress_wright(T, S, pressure, rho, drho_dp, start, npts) - real, intent(in), dimension(:) :: T !< Potential temperature relative to the surface [degC]. - real, intent(in), dimension(:) :: S !< Salinity [PSU]. - real, intent(in), dimension(:) :: pressure !< pressure [Pa]. - real, intent(out), dimension(:) :: rho !< In situ density [kg m-3]. - real, intent(out), dimension(:) :: drho_dp !< The partial derivative of density with pressure - !! (also the inverse of the square of sound speed) - !! [s2 m-2]. - integer, intent(in) :: start !< The starting point in the arrays. - integer, intent(in) :: npts !< The number of values to calculate. + real, intent(in), dimension(:) :: T !< Potential temperature relative to the surface [degC]. + real, intent(in), dimension(:) :: S !< Salinity [PSU]. + real, intent(in), dimension(:) :: pressure !< pressure [Pa]. + real, intent(inout), dimension(:) :: rho !< In situ density [kg m-3]. + real, intent(inout), dimension(:) :: drho_dp !< The partial derivative of density with pressure + !! (also the inverse of the square of sound speed) + !! [s2 m-2]. + integer, intent(in) :: start !< The starting point in the arrays. + integer, intent(in) :: npts !< The number of values to calculate. ! Coded by R. Hallberg, 1/01 ! Local variables @@ -428,18 +428,18 @@ subroutine int_density_dz_wright(T, S, z_t, z_b, rho_ref, rho_0, G_e, HII, HIO, !! equation of state. real, intent(in) :: G_e !< The Earth's gravitational acceleration [m2 Z-1 s-2 ~> m s-2]. real, dimension(HIO%isd:HIO%ied,HIO%jsd:HIO%jed), & - intent(out) :: dpa !< The change in the pressure anomaly across the + intent(inout) :: dpa !< The change in the pressure anomaly across the !! layer [Pa]. real, dimension(HIO%isd:HIO%ied,HIO%jsd:HIO%jed), & - optional, intent(out) :: intz_dpa !< The integral through the thickness of the layer + optional, intent(inout) :: intz_dpa !< The integral through the thickness of the layer !! of the pressure anomaly relative to the anomaly !! at the top of the layer [Pa Z ~> Pa m]. real, dimension(HIO%IsdB:HIO%IedB,HIO%jsd:HIO%jed), & - optional, intent(out) :: intx_dpa !< The integral in x of the difference between the + optional, intent(inout) :: 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 [Pa]. real, dimension(HIO%isd:HIO%ied,HIO%JsdB:HIO%JedB), & - optional, intent(out) :: inty_dpa !< The integral in y of the difference between the + optional, intent(inout) :: 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 [Pa]. real, dimension(HII%isd:HII%ied,HII%jsd:HII%jed), & @@ -629,18 +629,18 @@ subroutine int_spec_vol_dp_wright(T, S, p_t, p_b, spv_ref, HI, dza, & !! 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 + intent(inout) :: dza !< The change in the geopotential anomaly across !! the layer [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 + optional, intent(inout) :: intp_dza !< The integral in pressure through the layer of !! the geopotential anomaly relative to the anomaly !! at the bottom of the layer [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 + optional, intent(inout) :: 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 [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 + optional, intent(inout) :: 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 [m2 s-2]. integer, optional, intent(in) :: halo_size !< The width of halo points on which to calculate From 3388236b646e2742b735ec64644e10b21add18c8 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Tue, 4 Feb 2020 18:05:09 -0500 Subject: [PATCH 043/316] (+)Corrected units of ADAPT_TIME_RATIO Corrected the documented units of ADAPT_TIME_RATIO, which is only logged when REGRIDDING_COORDINATE_MODE is REGRIDDING_ADAPTIVE. Also removed unneeded comments in coord_slight.F90. All answers are bitwise identical, and the MOM_parameter_doc files are unchanged in the MOM6-examples test suite. --- src/ALE/MOM_regridding.F90 | 2 +- src/ALE/coord_slight.F90 | 4 ++-- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/src/ALE/MOM_regridding.F90 b/src/ALE/MOM_regridding.F90 index 423cc65687..e23e740c9c 100644 --- a/src/ALE/MOM_regridding.F90 +++ b/src/ALE/MOM_regridding.F90 @@ -574,7 +574,7 @@ subroutine initialize_regridding(CS, GV, US, max_depth, param_file, mdl, coord_m if (coordinateMode(coord_mode) == REGRIDDING_ADAPTIVE) then call get_param(param_file, mdl, "ADAPT_TIME_RATIO", adaptTimeRatio, & - "Ratio of ALE timestep to grid timescale.", units="s", default=1e-1) !### Should the units be "nondim"? + "Ratio of ALE timestep to grid timescale.", units="nondim", default=1e-1) call get_param(param_file, mdl, "ADAPT_ZOOM_DEPTH", adaptZoom, & "Depth of near-surface zooming region.", units="m", default=200.0, scale=GV%m_to_H) call get_param(param_file, mdl, "ADAPT_ZOOM_COEFF", adaptZoomCoeff, & diff --git a/src/ALE/coord_slight.F90 b/src/ALE/coord_slight.F90 index 2e41d36473..92de6e1ec3 100644 --- a/src/ALE/coord_slight.F90 +++ b/src/ALE/coord_slight.F90 @@ -687,7 +687,7 @@ subroutine rho_interfaces_col(rho_col, h_col, z_col, rho_tgt, nz, z_col_new, & if (k_layer > 0) then ! The new location is inside of layer k_layer. ! Note that this is coded assuming that this layer is stably stratified. if (.not.(ppoly_i_E(k1,2) > ppoly_i_E(k1,1))) call MOM_error(FATAL, & - "build_grid_SLight: Erroneously searching for an interface in an unstratified layer.") !### COMMENT OUT LATER? + "build_grid_SLight: Erroneously searching for an interface in an unstratified layer.") ! Use the false position method to find the location (degree <= 1) or the first guess. zf = (rt - ppoly_i_E(k1,1)) / (ppoly_i_E(k1,2) - ppoly_i_E(k1,1)) @@ -698,7 +698,7 @@ subroutine rho_interfaces_col(rho_col, h_col, z_col, rho_tgt, nz, z_col_new, & ! Bracket the root. zf1 = 0.0 ; rfn1 = a(1) zf2 = 1.0 ; rfn2 = a(1) + (a(2) + (a(3) + (a(4) + a(5)))) - if (rfn1 * rfn2 > 0.0) call MOM_error(FATAL, "build_grid_SLight: Bad bracketing.") !### COMMENT OUT LATER? + if (rfn1 * rfn2 > 0.0) call MOM_error(FATAL, "build_grid_SLight: Bad bracketing.") do itt=1,max_itt rfn = a(1) + zf*(a(2) + zf*(a(3) + zf*(a(4) + zf*a(5)))) From 12d3aff3504f732718435442796d1639c13b307e Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Tue, 4 Feb 2020 18:05:32 -0500 Subject: [PATCH 044/316] (*)+Added run-time parameter SURFACE_2018_ANSWERS Added a new run-time parameter SURFACE_2018_ANSWERS to improve the calculation of the surface properties in non-Boussinesq calculations or in the limit where the total water column is exceptionally thin. Also corrected a bug in which the value of src_state%salt_deficit is too large by a factor of 1000000. This array does not appear to be used, so this bug might not impact any solutions. By default all answers are bitwise identical, but these changes do add and reorder entries in the MOM_parameter_doc files. --- src/core/MOM.F90 | 109 ++++++++++++++++++++++++++++++----------------- 1 file changed, 71 insertions(+), 38 deletions(-) diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index 690e5250db..4b286783fc 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -194,8 +194,8 @@ module MOM !! multiple coupling timesteps. real :: t_dyn_rel_diag !< The time of the diagnostics relative to diabatic processes and remapping !! [T ~> s]. t_dyn_rel_diag is always positive, since the diagnostics must lag. - integer :: ndyn_per_adv = 0 !< Number of calls to dynamics since the last call to advection. - !### Must be saved if thermo spans coupling? + logical :: preadv_h_stored = .false. !< If true, the thicknesses from before the advective cycle + !! have been stored for use in diagnostics. type(diag_ctrl) :: diag !< structure to regulate diagnostic output timing type(vertvisc_type) :: visc !< structure containing vertical viscosities, @@ -292,6 +292,9 @@ module MOM real :: bad_val_sst_min !< Minimum SST before triggering bad value message [degC] real :: bad_val_sss_max !< Maximum SSS before triggering bad value message [ppt] real :: bad_val_col_thick !< Minimum column thickness before triggering bad value message [m] + logical :: answers_2018 !< If true, use expressions for the surface properties that recover + !! the answers from the end of 2018. Otherwise, use more appropriate + !! expressions that differ at roundoff for non-Boussinsq cases. type(MOM_diag_IDs) :: IDs !< Handles used for diagnostics. type(transport_diag_IDs) :: transport_IDs !< Handles used for transport diagnostics. @@ -330,7 +333,8 @@ module MOM !< Pointer to the MOM along-isopycnal tracer diffusion control structure type(tracer_flow_control_CS), pointer :: tracer_flow_CSp => NULL() !< Pointer to the control structure that orchestrates the calling of tracer packages - !### update_OBC_CS might not be needed outside of initialization? + ! Although update_OBC_CS is not used directly outside of initialization, other modules + ! set pointers to this type, so it should be kept for the duration of the run. type(update_OBC_CS), pointer :: update_OBC_CSp => NULL() !< Pointer to the control structure for updating open boundary condition properties type(ocean_OBC_type), pointer :: OBC => NULL() @@ -660,12 +664,12 @@ subroutine step_MOM(forces, fluxes, sfc_state, Time_start, time_int_in, CS, & 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 stored at the first call. - if (CS%ndyn_per_adv == 0 .and. CS%t_dyn_rel_adv == 0.) then + ! Store pre-dynamics thicknesses for proper diagnostic remapping for transports or + ! advective tendencies. If there are more than one dynamics steps per advective + ! step (i.e DT_THERM > DT), this needs to be stored at the first dynamics call. + if (.not.CS%preadv_h_stored .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 + CS%preadv_h_stored = .true. endif ! The pre-dynamics velocities might be stored for debugging truncations. @@ -719,7 +723,6 @@ subroutine step_MOM(forces, fluxes, sfc_state, Time_start, time_int_in, CS, & if (do_advection) then ! Do advective transport and lateral tracer mixing. call step_MOM_tracer_dyn(CS, G, GV, US, h, Time_local) - CS%ndyn_per_adv = 0 if (CS%diabatic_first .and. abs(CS%t_dyn_rel_thermo) > 1e-6*dt) call MOM_error(FATAL, & "step_MOM: Mismatch between the dynamics and diabatic times "//& "with DIABATIC_FIRST.") @@ -1121,6 +1124,8 @@ subroutine step_MOM_tracer_dyn(CS, G, GV, US, h, Time_local) call do_group_pass(pass_T_S, G%Domain, clock=id_clock_pass) endif + CS%preadv_h_stored = .false. + end subroutine step_MOM_tracer_dyn !> MOM_step_thermo orchestrates the thermodynamic time stepping and vertical @@ -1562,6 +1567,7 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & ! with accumulated heat deficit returned to surface ocean. logical :: bound_salinity ! If true, salt is added to keep salinity above ! a minimum value, and the deficit is reported. + logical :: default_2018_answers ! The default setting for the various 2018_ANSWERS flags. logical :: use_conT_absS ! If true, the prognostics T & S are conservative temperature ! and absolute salinity. Care should be taken to convert them ! to potential temperature and practical salinity before @@ -1875,6 +1881,13 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & "triggered, if CHECK_BAD_SURFACE_VALS is true.", units="m", & default=0.0) endif + call get_param(param_file, "MOM", "DEFAULT_2018_ANSWERS", default_2018_answers, & + "This sets the default value for the various _2018_ANSWERS parameters.", & + default=.true.) + call get_param(param_file, "MOM", "SURFACE_2018_ANSWERS", CS%answers_2018, & + "If true, use expressions for the surface properties that recover the answers "//& + "from the end of 2018. Otherwise, use more appropriate expressions that differ "//& + "at roundoff for non-Boussinsq cases.", default=default_2018_answers) call get_param(param_file, "MOM", "SAVE_INITIAL_CONDS", save_IC, & "If true, write the initial conditions to a file given "//& @@ -2711,21 +2724,26 @@ subroutine extract_surface_state(CS, sfc_state) !! structure shared with the calling routine !! data in this structure is intent out. - ! local + ! Local variables real :: hu, hv ! Thicknesses interpolated to velocity points [H ~> m or kg m-2] - type(ocean_grid_type), pointer :: G => NULL() !< 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() !< structure containing vertical grid info type(unit_scale_type), pointer :: US => NULL() !< structure containing various unit conversion factors real, dimension(:,:,:), pointer :: & h => NULL() !< h : layer thickness [H ~> m or kg m-2] - real :: depth(SZI_(CS%G)) !< Distance from the surface in depth units [Z ~> m] + real :: depth(SZI_(CS%G)) !< Distance from the surface in depth units [Z ~> m] or [H ~> m or kg m-2] real :: depth_ml !< Depth over which to average to determine mixed - !! layer properties [Z ~> m] - real :: dh !< Thickness of a layer within the mixed layer [Z ~> m] + !! layer properties [Z ~> m] or [H ~> m or kg m-2] + real :: dh !< Thickness of a layer within the mixed layer [Z ~> m] or [H ~> m or kg m-2] real :: mass !< Mass per unit area of a layer [kg m-2] real :: bathy_m !< The depth of bathymetry [m] (not Z), used for error checking. real :: T_freeze !< freezing temperature [degC] + real :: I_depth !< The inverse of depth [Z-1 ~> m-1] or [H-1 ~> m-1 or m2 kg-1] + real :: missing_depth !< The portion of depth_ml that can not be found in a column [H ~> m or kg m-2] + real :: H_rescale !< A conversion factor from thickness units to the units used in the + !! calculation of properties of the uppermost ocean [nondim] or [Z H-1 ~> 1 or m3 kg-1] + ! After the ANSWERS_2018 flag has been obsoleted, H_rescale will be 1. real :: delT(SZI_(CS%G)) !< T-T_freeze [degC] logical :: use_temperature !< If true, temp and saln used as state variables. integer :: i, j, k, is, ie, js, je, nz, numberOfErrors, ig, jg @@ -2777,9 +2795,9 @@ subroutine extract_surface_state(CS, sfc_state) enddo ; enddo else ! (CS%Hmix >= 0.0) - !### This calculation should work in thickness (H) units instead of Z, but that - !### would change answers at roundoff in non-Boussinesq cases. + H_rescale = 1.0 ; if (CS%answers_2018) H_rescale = GV%H_to_Z depth_ml = CS%Hmix + if (.not.CS%answers_2018) depth_ml = CS%Hmix*GV%Z_to_H ! Determine the mean tracer properties of the uppermost depth_ml fluid. !$OMP parallel do default(shared) private(depth,dh) do j=js,je @@ -2793,8 +2811,8 @@ subroutine extract_surface_state(CS, sfc_state) enddo do k=1,nz ; do i=is,ie - if (depth(i) + h(i,j,k)*GV%H_to_Z < depth_ml) then - dh = h(i,j,k)*GV%H_to_Z + if (depth(i) + h(i,j,k)*H_rescale < depth_ml) then + dh = h(i,j,k)*H_rescale elseif (depth(i) < depth_ml) then dh = depth_ml - depth(i) else @@ -2810,16 +2828,36 @@ subroutine extract_surface_state(CS, sfc_state) enddo ; enddo ! Calculate the average properties of the mixed layer depth. do i=is,ie - if (depth(i) < GV%H_subroundoff*GV%H_to_Z) & - depth(i) = GV%H_subroundoff*GV%H_to_Z - if (use_temperature) then - sfc_state%SST(i,j) = sfc_state%SST(i,j) / depth(i) - sfc_state%SSS(i,j) = sfc_state%SSS(i,j) / depth(i) + if (CS%answers_2018) then + if (depth(i) < GV%H_subroundoff*H_rescale) & + depth(i) = GV%H_subroundoff*H_rescale + if (use_temperature) then + sfc_state%SST(i,j) = sfc_state%SST(i,j) / depth(i) + sfc_state%SSS(i,j) = sfc_state%SSS(i,j) / depth(i) + else + sfc_state%sfc_density(i,j) = sfc_state%sfc_density(i,j) / depth(i) + endif else - sfc_state%sfc_density(i,j) = sfc_state%sfc_density(i,j) / depth(i) + if (depth(i) < GV%H_subroundoff*H_rescale) then + I_depth = 1.0 / (GV%H_subroundoff*H_rescale) + missing_depth = GV%H_subroundoff*H_rescale - depth(i) + if (use_temperature) then + sfc_state%SST(i,j) = (sfc_state%SST(i,j) + missing_depth*CS%tv%T(i,j,1)) * I_depth + sfc_state%SSS(i,j) = (sfc_state%SSS(i,j) + missing_depth*CS%tv%S(i,j,1)) * I_depth + else + sfc_state%sfc_density(i,j) = (sfc_state%sfc_density(i,j) + & + missing_depth*US%R_to_kg_m3*GV%Rlay(1)) * I_depth + endif + else + I_depth = 1.0 / depth(i) + if (use_temperature) then + sfc_state%SST(i,j) = sfc_state%SST(i,j) * I_depth + sfc_state%SSS(i,j) = sfc_state%SSS(i,j) * I_depth + else + sfc_state%sfc_density(i,j) = sfc_state%sfc_density(i,j) * I_depth + endif + endif endif - !### Verify that this is no longer needed. - ! sfc_state%Hml(i,j) = US%Z_to_m * depth(i) enddo enddo ! end of j loop @@ -2828,9 +2866,8 @@ subroutine extract_surface_state(CS, sfc_state) ! required by the speed diagnostic on the non-symmetric grid. ! This assumes that u and v halos have already been updated. if (CS%Hmix_UV>0.) then - !### This calculation should work in thickness (H) units instead of Z, but that - !### would change answers at roundoff in non-Boussinesq cases. depth_ml = CS%Hmix_UV + if (.not.CS%answers_2018) depth_ml = CS%Hmix_UV*GV%Z_to_H !$OMP parallel do default(shared) private(depth,dh,hv) do J=js-1,ie do i=is,ie @@ -2838,7 +2875,7 @@ subroutine extract_surface_state(CS, sfc_state) sfc_state%v(i,J) = 0.0 enddo do k=1,nz ; do i=is,ie - hv = 0.5 * (h(i,j,k) + h(i,j+1,k)) * GV%H_to_Z + hv = 0.5 * (h(i,j,k) + h(i,j+1,k)) * H_rescale if (depth(i) + hv < depth_ml) then dh = hv elseif (depth(i) < depth_ml) then @@ -2851,9 +2888,7 @@ subroutine extract_surface_state(CS, sfc_state) enddo ; enddo ! Calculate the average properties of the mixed layer depth. do i=is,ie - if (depth(i) < GV%H_subroundoff*GV%H_to_Z) & - depth(i) = GV%H_subroundoff*GV%H_to_Z - sfc_state%v(i,J) = sfc_state%v(i,J) / depth(i) + sfc_state%v(i,J) = sfc_state%v(i,J) / max(depth(i), GV%H_subroundoff*H_rescale) enddo enddo ! end of j loop @@ -2864,7 +2899,7 @@ subroutine extract_surface_state(CS, sfc_state) sfc_state%u(I,j) = 0.0 enddo do k=1,nz ; do I=is-1,ie - hu = 0.5 * (h(i,j,k) + h(i+1,j,k)) * GV%H_to_Z + hu = 0.5 * (h(i,j,k) + h(i+1,j,k)) * H_rescale if (depth(i) + hu < depth_ml) then dh = hu elseif (depth(I) < depth_ml) then @@ -2877,9 +2912,7 @@ subroutine extract_surface_state(CS, sfc_state) enddo ; enddo ! Calculate the average properties of the mixed layer depth. do I=is-1,ie - if (depth(I) < GV%H_subroundoff*GV%H_to_Z) & - depth(I) = GV%H_subroundoff*GV%H_to_Z - sfc_state%u(I,j) = sfc_state%u(I,j) / depth(I) + sfc_state%u(I,j) = sfc_state%u(I,j) / max(depth(I), GV%H_subroundoff*H_rescale) enddo enddo ! end of j loop else ! Hmix_UV<=0. @@ -2933,7 +2966,7 @@ subroutine extract_surface_state(CS, sfc_state) !$OMP parallel do default(shared) do j=js,je ; do i=is,ie ! Convert from gSalt to kgSalt - sfc_state%salt_deficit(i,j) = 1000.0 * US%R_to_kg_m3*US%Z_to_m*CS%tv%salt_deficit(i,j) + sfc_state%salt_deficit(i,j) = 0.001 * US%R_to_kg_m3*US%Z_to_m*CS%tv%salt_deficit(i,j) enddo ; enddo endif if (allocated(sfc_state%TempxPmE) .and. associated(CS%tv%TempxPmE)) then From 765fa3737c2b4cdf6f5003b4eccb09e500400ab3 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Tue, 4 Feb 2020 18:06:32 -0500 Subject: [PATCH 045/316] Added parentheses in calculate_bkgnd_mixing Added parentheses to the calculation of Kd_bkgrd in calculate_bkgnd_mixing. The specified order of arithmetic is the one that compilers are likely to adopt, so answers seem unlikely to change. All answers in the MOM6-examples test cases are bitwise identical. --- src/parameterizations/vertical/MOM_bkgnd_mixing.F90 | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/src/parameterizations/vertical/MOM_bkgnd_mixing.F90 b/src/parameterizations/vertical/MOM_bkgnd_mixing.F90 index 0cbe700518..57199f38d0 100644 --- a/src/parameterizations/vertical/MOM_bkgnd_mixing.F90 +++ b/src/parameterizations/vertical/MOM_bkgnd_mixing.F90 @@ -464,8 +464,7 @@ subroutine calculate_bkgnd_mixing(h, tv, N2_lay, Kd_lay, Kv, j, G, GV, US, CS) do i=is,ie bckgrnd_vdc_psis = CS%bckgrnd_vdc_psim * exp(-(0.4*(G%geoLatT(i,j)+28.9))**2) bckgrnd_vdc_psin = CS%bckgrnd_vdc_psim * exp(-(0.4*(G%geoLatT(i,j)-28.9))**2) - !### Add parentheses. - CS%Kd_bkgnd(i,j,:) = CS%bckgrnd_vdc_eq + bckgrnd_vdc_psin + bckgrnd_vdc_psis + CS%Kd_bkgnd(i,j,:) = (CS%bckgrnd_vdc_eq + bckgrnd_vdc_psin) + bckgrnd_vdc_psis if (G%geoLatT(i,j) < -10.0) then CS%Kd_bkgnd(i,j,:) = CS%Kd_bkgnd(i,j,:) + CS%bckgrnd_vdc1 From f2e4644d2df0959c9ed45db6c5088c1f0b2dfd5e Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Tue, 4 Feb 2020 19:05:43 -0500 Subject: [PATCH 046/316] (+)Added the runtime parameter KH_BG_2D_BUG Added the new runtime parameter KH_BG_2D_BUG to correct the calculation of viscosities at the corners when USE_KH_BG_2D is true. By default all answers are bitwise identical, but there is a new entry in the MOM_parameter_doc files when USE_KH_BG_2D is true. --- src/parameterizations/lateral/MOM_hor_visc.F90 | 17 +++++++++++++++-- 1 file changed, 15 insertions(+), 2 deletions(-) diff --git a/src/parameterizations/lateral/MOM_hor_visc.F90 b/src/parameterizations/lateral/MOM_hor_visc.F90 index 63811e14d7..0298bac5ab 100644 --- a/src/parameterizations/lateral/MOM_hor_visc.F90 +++ b/src/parameterizations/lateral/MOM_hor_visc.F90 @@ -67,6 +67,8 @@ module MOM_hor_visc !! viscosity is modified to include a term that !! scales quadratically with the velocity shears. logical :: use_Kh_bg_2d !< Read 2d background viscosity from a file. + logical :: Kh_bg_2d_bug !< If true, retain an answer-changing horizontal indexing bug + !! in setting the corner-point viscosities when USE_KH_BG_2D=True. real :: Kh_bg_min !< The minimum value allowed for Laplacian horizontal !! viscosity [L2 T-1 ~> m2 s-1]. The default is 0.0. logical :: use_land_mask !< Use the land mask for the computation of thicknesses @@ -1651,6 +1653,11 @@ subroutine hor_visc_init(Time, G, US, param_file, diag, CS, MEKE) "If true, read a file containing 2-d background harmonic "//& "viscosities. The final viscosity is the maximum of the other "//& "terms and this background value.", default=.false.) + if (CS%use_Kh_bg_2d) then + call get_param(param_file, mdl, "KH_BG_2D_BUG", CS%Kh_bg_2d_bug, & + "If true, retain an answer-changing horizontal indexing bug in setting "//& + "the corner-point viscosities when USE_KH_BG_2D=True.", default=.true.) + endif call get_param(param_file, mdl, "USE_GME", CS%use_GME, & "If true, use the GM+E backscatter scheme in association \n"//& @@ -1872,8 +1879,14 @@ subroutine hor_visc_init(Time, G, US, param_file, diag, CS, MEKE) CS%Kh_bg_xy(I,J) = MAX(Kh, Kh_vel_scale * sqrt(grid_sp_q2)) ! Use the larger of the above and values read from a file - !### This expression uses inconsistent staggering - if (CS%use_Kh_bg_2d) CS%Kh_bg_xy(I,J) = MAX(CS%Kh_bg_2d(i,j), CS%Kh_bg_xy(I,J)) + if (CS%use_Kh_bg_2d) then ; if (CS%Kh_bg_2d_bug) then + ! This option is unambiguously wrong, and should be obsoleted as soon as possible. + CS%Kh_bg_xy(I,J) = MAX(CS%Kh_bg_2d(i,j), CS%Kh_bg_xy(I,J)) + else + CS%Kh_bg_xy(I,J) = MAX(CS%Kh_bg_xy(I,J), & + 0.25*((CS%Kh_bg_2d(i,j) + CS%Kh_bg_2d(i+1,j+1)) + & + (CS%Kh_bg_2d(i+1,j) + CS%Kh_bg_2d(i,j+1))) ) + endif ; endif ! Use the larger of the above and a function of sin(latitude) if (Kh_sin_lat>0.) then From 6bf9284e7f09beeadf247761a473a487e0014d41 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Tue, 4 Feb 2020 19:06:16 -0500 Subject: [PATCH 047/316] +Added MEKE_GEOMETRIC_2018_ANSWERS Added the runtime parameter MEKE_GEOMETRIC_2018_ANSWERS to change to a rotationally symmetric calculation when MEKE_GEOMETRIC is true. Also removed a number of unneeded hard carriage returns in the descriptions of several of the parameters used by MOM_thickness_diffuse. By default all answers are bitwise identical, but comments in the MOM_parameter_doc files are reformatted. --- .../lateral/MOM_thickness_diffuse.F90 | 66 +++++++++++++------ 1 file changed, 45 insertions(+), 21 deletions(-) diff --git a/src/parameterizations/lateral/MOM_thickness_diffuse.F90 b/src/parameterizations/lateral/MOM_thickness_diffuse.F90 index 9c236fd937..450d6fea9b 100644 --- a/src/parameterizations/lateral/MOM_thickness_diffuse.F90 +++ b/src/parameterizations/lateral/MOM_thickness_diffuse.F90 @@ -69,6 +69,9 @@ module MOM_thickness_diffuse !! the GEOMETRIC thickness difussion [nondim] real :: MEKE_GEOMETRIC_epsilon !< Minimum Eady growth rate for the GEOMETRIC thickness !! diffusivity [T-1 ~> s-1]. + logical :: MEKE_GEOM_answers_2018 !< If true, use expressions in the MEKE_GEOMETRIC calculation + !! that recover the answers from the original implementation. + !! Otherwise, use expressions that satisfy rotational symmetry. logical :: Use_KH_in_MEKE !< If true, uses the thickness diffusivity calculated here to diffuse MEKE. logical :: GM_src_alt !< If true, use the GM energy conversion form S^2*N^2*kappa rather !! than the streamfunction for the GM source term. @@ -151,7 +154,7 @@ subroutine thickness_diffuse(h, uhtr, vhtr, tv, dt, G, GV, US, MEKE, VarMix, CDp real :: KH_u_lay(SZI_(G), SZJ_(G)) ! layer ave thickness diffusivities [L2 T-1 ~> m2 s-1] real :: KH_v_lay(SZI_(G), SZJ_(G)) ! layer ave thickness diffusivities [L2 T-1 ~> m2 s-1] - if (.not. associated(CS)) call MOM_error(FATAL, "MOM_thickness_diffuse:"// & + if (.not. associated(CS)) call MOM_error(FATAL, "MOM_thickness_diffuse: "//& "Module must be initialized before it is used.") if ((.not.CS%thickness_diffuse) .or. & @@ -366,13 +369,25 @@ subroutine thickness_diffuse(h, uhtr, vhtr, tv, dt, G, GV, US, MEKE, VarMix, CDp if (associated(MEKE)) then ; if (associated(MEKE%Kh)) then if (CS%MEKE_GEOMETRIC) then -!$OMP do - do j=js,je ; do I=is,ie - !### This will not give bitwise rotational symmetry. Add parentheses. - MEKE%Kh(i,j) = CS%MEKE_GEOMETRIC_alpha * MEKE%MEKE(i,j) / & - (0.25*(VarMix%SN_u(I,j)+VarMix%SN_u(I-1,j)+VarMix%SN_v(i,J)+VarMix%SN_v(i,J-1)) + & - CS%MEKE_GEOMETRIC_epsilon) - enddo ; enddo + if (CS%MEKE_GEOM_answers_2018) then + !$OMP do + do j=js,je ; do I=is,ie + ! This does not give bitwise rotational symmetry. + MEKE%Kh(i,j) = CS%MEKE_GEOMETRIC_alpha * MEKE%MEKE(i,j) / & + (0.25*(VarMix%SN_u(I,j)+VarMix%SN_u(I-1,j) + & + VarMix%SN_v(i,J)+VarMix%SN_v(i,J-1)) + & + CS%MEKE_GEOMETRIC_epsilon) + enddo ; enddo + else + !$OMP do + do j=js,je ; do I=is,ie + ! With the additional parentheses this gives bitwise rotational symmetry. + MEKE%Kh(i,j) = CS%MEKE_GEOMETRIC_alpha * MEKE%MEKE(i,j) / & + (0.25*((VarMix%SN_u(I,j)+VarMix%SN_u(I-1,j)) + & + (VarMix%SN_v(i,J)+VarMix%SN_v(i,J-1))) + & + CS%MEKE_GEOMETRIC_epsilon) + enddo ; enddo + endif endif endif ; endif @@ -1768,7 +1783,10 @@ subroutine thickness_diffuse_init(Time, G, GV, US, param_file, diag, CDp, CS) #include "version_variable.h" character(len=40) :: mdl = "MOM_thickness_diffuse" ! This module's name. real :: omega ! The Earth's rotation rate [T-1 ~> s-1] - real :: strat_floor + real :: strat_floor ! A floor for Brunt-Vasaila frequency in the Ferrari et al. 2010, + ! streamfunction formulation, expressed as a fraction of planetary + ! rotation [nondim]. + logical :: default_2018_answers ! The default setting for the various 2018_ANSWERS flags. if (associated(CS)) then call MOM_error(WARNING, & @@ -1852,32 +1870,38 @@ subroutine thickness_diffuse_init(Time, G, GV, US, param_file, diag, CDp, CS) default=.false., debuggingParam=.true.) call get_param(param_file, mdl, "MEKE_GM_SRC_ALT", CS%GM_src_alt, & - "If true, use the GM energy conversion form S^2*N^2*kappa rather \n"//& + "If true, use the GM energy conversion form S^2*N^2*kappa rather "//& "than the streamfunction for the GM source term.", default=.false.) call get_param(param_file, mdl, "MEKE_GEOMETRIC", CS%MEKE_GEOMETRIC, & - "If true, uses the GM coefficient formulation \n"//& - "from the GEOMETRIC framework (Marshall et al., 2012).", default=.false.) + "If true, uses the GM coefficient formulation from the GEOMETRIC "//& + "framework (Marshall et al., 2012).", default=.false.) if (CS%MEKE_GEOMETRIC) then - call get_param(param_file, mdl, "MEKE_GEOMETRIC_EPSILON", CS%MEKE_GEOMETRIC_epsilon, & - "Minimum Eady growth rate used in the calculation of \n"//& - "GEOMETRIC thickness diffusivity.", units="s-1", default=1.0e-7, scale=US%T_to_s) - + "Minimum Eady growth rate used in the calculation of GEOMETRIC "//& + "thickness diffusivity.", units="s-1", default=1.0e-7, scale=US%T_to_s) call get_param(param_file, mdl, "MEKE_GEOMETRIC_ALPHA", CS%MEKE_GEOMETRIC_alpha, & - "The nondimensional coefficient governing the efficiency of the GEOMETRIC \n"//& + "The nondimensional coefficient governing the efficiency of the GEOMETRIC "//& "thickness diffusion.", units="nondim", default=0.05) + + call get_param(param_file, mdl, "DEFAULT_2018_ANSWERS", default_2018_answers, & + "This sets the default value for the various _2018_ANSWERS parameters.", & + default=.true.) + call get_param(param_file, mdl, "MEKE_GEOMETRIC_2018_ANSWERS", CS%MEKE_GEOM_answers_2018, & + "If true, use expressions in the MEKE_GEOMETRIC calculation that recover the "//& + "answers from the original implementation. Otherwise, use expressions that "//& + "satisfy rotational symmetry.", default=default_2018_answers) endif call get_param(param_file, mdl, "USE_KH_IN_MEKE", CS%Use_KH_in_MEKE, & - "If true, uses the thickness diffusivity calculated here to diffuse \n"//& - "MEKE.", default=.false.) + "If true, uses the thickness diffusivity calculated here to diffuse MEKE.", & + default=.false.) call get_param(param_file, mdl, "USE_GME", CS%use_GME_thickness_diffuse, & - "If true, use the GM+E backscatter scheme in association \n"//& + "If true, use the GM+E backscatter scheme in association "//& "with the Gent and McWilliams parameterization.", default=.false.) call get_param(param_file, mdl, "USE_GM_WORK_BUG", CS%use_GM_work_bug, & - "If true, compute the top-layer work tendency on the u-grid " // & + "If true, compute the top-layer work tendency on the u-grid "//& "with the incorrect sign, for legacy reproducibility.", & default=.true.) From d20d551e04f366e8dd878066a302d029a2d93dde Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 5 Feb 2020 10:11:10 -0500 Subject: [PATCH 048/316] +Added cont_stencil arg to initialize_dyn routines Added the optional argument cont_stencil to the three initialize_dyn routines and used this information to reduce the halo sizes to the minimum required extents in three halo updates, which should improve parallel performance when MOM is bandwidth limited. All answers are bitwise identical, but there are new optional arguments. --- src/core/MOM.F90 | 13 +++++++------ src/core/MOM_dynamics_split_RK2.F90 | 16 +++++++++------- src/core/MOM_dynamics_unsplit.F90 | 7 +++++-- src/core/MOM_dynamics_unsplit_RK2.F90 | 7 +++++-- 4 files changed, 26 insertions(+), 17 deletions(-) diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index 4b286783fc..18e2c2e5b8 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -225,6 +225,7 @@ module MOM logical :: debug !< If true, write verbose checksums for debugging purposes. integer :: ntrunc !< number u,v truncations since last call to write_energy + integer :: cont_stencil !< The stencil for thickness from the continuity solver. ! These elements are used to control the dynamics updates. logical :: do_dynamics !< If false, does not call step_MOM_dyn_*. This is an !! undocumented run-time flag that is fragile. @@ -930,7 +931,7 @@ subroutine step_MOM_dynamics(forces, p_surf_begin, p_surf_end, dt, dt_thermo, & call thickness_diffuse(h, CS%uhtr, CS%vhtr, CS%tv, dt_thermo, G, GV, US, & CS%MEKE, CS%VarMix, CS%CDp, CS%thickness_diffuse_CSp) call cpu_clock_end(id_clock_thick_diff) - call pass_var(h, G%Domain, clock=id_clock_pass) !###, halo=max(2,cont_stensil)) + call pass_var(h, G%Domain, clock=id_clock_pass, halo=max(2,CS%cont_stencil)) call disable_averaging(CS%diag) if (showCallTree) call callTree_waypoint("finished thickness_diffuse_first (step_MOM)") @@ -1005,7 +1006,7 @@ subroutine step_MOM_dynamics(forces, p_surf_begin, p_surf_end, dt, dt_thermo, & if (CS%debug) call hchksum(h,"Post-thickness_diffuse h", G%HI, haloshift=1, scale=GV%H_to_m) call cpu_clock_end(id_clock_thick_diff) - call pass_var(h, G%Domain, clock=id_clock_pass) !###, halo=max(2,cont_stensil)) + call pass_var(h, G%Domain, clock=id_clock_pass, halo=max(2,CS%cont_stencil)) if (showCallTree) call callTree_waypoint("finished thickness_diffuse (step_MOM)") endif @@ -1020,7 +1021,7 @@ subroutine step_MOM_dynamics(forces, p_surf_begin, p_surf_end, dt, dt_thermo, & call mixedlayer_restrat(h, CS%uhtr, CS%vhtr, CS%tv, forces, dt, CS%visc%MLD, & CS%VarMix, G, GV, US, CS%mixedlayer_restrat_CSp) call cpu_clock_end(id_clock_ml_restrat) - call pass_var(h, G%Domain, clock=id_clock_pass) !###, halo=max(2,cont_stensil)) + call pass_var(h, G%Domain, clock=id_clock_pass, halo=max(2,CS%cont_stencil)) if (CS%debug) then call hchksum(h,"Post-mixedlayer_restrat h", G%HI, haloshift=1, scale=GV%H_to_m) call uvchksum("Post-mixedlayer_restrat [uv]htr", & @@ -2327,7 +2328,7 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & CS%dt, CS%ADp, CS%CDp, MOM_internal_state, CS%VarMix, CS%MEKE, & CS%thickness_diffuse_CSp, & CS%OBC, CS%update_OBC_CSp, CS%ALE_CSp, CS%set_visc_CSp, & - CS%visc, dirs, CS%ntrunc, calc_dtbt=calc_dtbt) + CS%visc, dirs, CS%ntrunc, calc_dtbt=calc_dtbt, cont_stencil=CS%cont_stencil) if (CS%dtbt_reset_period > 0.0) then CS%dtbt_reset_interval = real_to_time(CS%dtbt_reset_period) ! Set dtbt_reset_time to be the next even multiple of dtbt_reset_interval. @@ -2345,13 +2346,13 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & param_file, diag, CS%dyn_unsplit_RK2_CSp, restart_CSp, & CS%ADp, CS%CDp, MOM_internal_state, CS%MEKE, CS%OBC, & CS%update_OBC_CSp, CS%ALE_CSp, CS%set_visc_CSp, CS%visc, dirs, & - CS%ntrunc) + CS%ntrunc, cont_stencil=CS%cont_stencil) else call initialize_dyn_unsplit(CS%u, CS%v, CS%h, Time, G, GV, US, & param_file, diag, CS%dyn_unsplit_CSp, restart_CSp, & CS%ADp, CS%CDp, MOM_internal_state, CS%MEKE, CS%OBC, & CS%update_OBC_CSp, CS%ALE_CSp, CS%set_visc_CSp, CS%visc, dirs, & - CS%ntrunc) + CS%ntrunc, cont_stencil=CS%cont_stencil) endif call callTree_waypoint("dynamics initialized (initialize_MOM)") diff --git a/src/core/MOM_dynamics_split_RK2.F90 b/src/core/MOM_dynamics_split_RK2.F90 index 8c016b11b0..005f73af11 100644 --- a/src/core/MOM_dynamics_split_RK2.F90 +++ b/src/core/MOM_dynamics_split_RK2.F90 @@ -232,10 +232,9 @@ module MOM_dynamics_split_RK2 contains !> RK2 splitting for time stepping MOM adiabatic dynamics -subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, & - Time_local, dt, forces, p_surf_begin, p_surf_end, & - uh, vh, uhtr, vhtr, eta_av, & - G, GV, US, CS, calc_dtbt, VarMix, MEKE, thickness_diffuse_CSp, Waves) +subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, Time_local, dt, forces, p_surf_begin, p_surf_end, & + uh, vh, uhtr, vhtr, eta_av, G, GV, US, CS, calc_dtbt, VarMix, & + MEKE, thickness_diffuse_CSp, Waves) type(ocean_grid_type), intent(inout) :: G !< ocean grid structure type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type @@ -272,8 +271,8 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, & 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(thickness_diffuse_CS), pointer :: thickness_diffuse_CSp!< Pointer to a structure containing - !! interface height diffusivities + type(thickness_diffuse_CS), pointer :: thickness_diffuse_CSp !< Pointer to a structure containing + !! interface height diffusivities type(wave_parameters_CS), optional, pointer :: Waves !< A pointer to a structure containing !! fields related to the surface wave conditions @@ -954,7 +953,7 @@ subroutine initialize_dyn_split_RK2(u, v, h, uh, vh, eta, Time, G, GV, US, param diag, CS, restart_CS, dt, Accel_diag, Cont_diag, MIS, & VarMix, MEKE, thickness_diffuse_CSp, & OBC, update_OBC_CSp, ALE_CSp, setVisc_CSp, & - visc, dirs, ntrunc, calc_dtbt) + visc, dirs, ntrunc, calc_dtbt, cont_stencil) type(ocean_grid_type), intent(inout) :: G !< ocean grid structure type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type @@ -995,6 +994,8 @@ subroutine initialize_dyn_split_RK2(u, v, h, uh, vh, eta, Time, G, GV, US, param !! the number of times the velocity is !! truncated (this should be 0). logical, intent(out) :: calc_dtbt !< If true, recalculate the barotropic time step + integer, optional, intent(out) :: cont_stencil !< The stencil for thickness + !! from the continuity solver. ! local variables real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: h_tmp @@ -1104,6 +1105,7 @@ subroutine initialize_dyn_split_RK2(u, v, h, uh, vh, eta, Time, G, GV, US, param grain=CLOCK_ROUTINE) call continuity_init(Time, G, GV, US, param_file, diag, CS%continuity_CSp) + if (present(cont_stencil)) cont_stencil = continuity_stencil(CS%continuity_CSp) call CoriolisAdv_init(Time, G, GV, US, param_file, diag, CS%ADp, CS%CoriolisAdv_CSp) if (use_tides) call tidal_forcing_init(Time, G, param_file, CS%tides_CSp) call PressureForce_init(Time, G, GV, US, param_file, diag, CS%PressureForce_CSp, & diff --git a/src/core/MOM_dynamics_unsplit.F90 b/src/core/MOM_dynamics_unsplit.F90 index ed7c440010..4030d0f2da 100644 --- a/src/core/MOM_dynamics_unsplit.F90 +++ b/src/core/MOM_dynamics_unsplit.F90 @@ -77,7 +77,7 @@ module MOM_dynamics_unsplit use MOM_ALE, only : ALE_CS use MOM_barotropic, only : barotropic_CS use MOM_boundary_update, only : update_OBC_data, update_OBC_CS -use MOM_continuity, only : continuity, continuity_init, continuity_CS +use MOM_continuity, only : continuity, continuity_init, continuity_CS, continuity_stencil use MOM_CoriolisAdv, only : CorAdCalc, CoriolisAdv_init, CoriolisAdv_CS use MOM_debugging, only : check_redundant use MOM_grid, only : ocean_grid_type @@ -561,7 +561,7 @@ end subroutine register_restarts_dyn_unsplit subroutine initialize_dyn_unsplit(u, v, h, Time, G, GV, US, param_file, diag, CS, & restart_CS, Accel_diag, Cont_diag, MIS, MEKE, & OBC, update_OBC_CSp, ALE_CSp, setVisc_CSp, & - visc, dirs, ntrunc) + visc, dirs, ntrunc, cont_stencil) type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type @@ -608,6 +608,8 @@ subroutine initialize_dyn_unsplit(u, v, h, Time, G, GV, US, param_file, diag, CS integer, target, intent(inout) :: ntrunc !< A target for the variable that !! records the number of times the velocity !! is truncated (this should be 0). + integer, optional, intent(out) :: cont_stencil !< The stencil for thickness + !! from the continuity solver. ! This subroutine initializes all of the variables that are used by this ! dynamic core, including diagnostics and the cpu clocks. @@ -651,6 +653,7 @@ subroutine initialize_dyn_unsplit(u, v, h, Time, G, GV, US, param_file, diag, CS Accel_diag%CAu => CS%CAu ; Accel_diag%CAv => CS%CAv call continuity_init(Time, G, GV, US, param_file, diag, CS%continuity_CSp) + if (present(cont_stencil)) cont_stencil = continuity_stencil(CS%continuity_CSp) call CoriolisAdv_init(Time, G, GV, US, param_file, diag, CS%ADp, CS%CoriolisAdv_CSp) if (use_tides) call tidal_forcing_init(Time, G, param_file, CS%tides_CSp) call PressureForce_init(Time, G, GV, US, param_file, diag, CS%PressureForce_CSp, & diff --git a/src/core/MOM_dynamics_unsplit_RK2.F90 b/src/core/MOM_dynamics_unsplit_RK2.F90 index 98de5b931c..7700507301 100644 --- a/src/core/MOM_dynamics_unsplit_RK2.F90 +++ b/src/core/MOM_dynamics_unsplit_RK2.F90 @@ -76,7 +76,7 @@ module MOM_dynamics_unsplit_RK2 use MOM_ALE, only : ALE_CS use MOM_boundary_update, only : update_OBC_data, update_OBC_CS use MOM_barotropic, only : barotropic_CS -use MOM_continuity, only : continuity, continuity_init, continuity_CS +use MOM_continuity, only : continuity, continuity_init, continuity_CS, continuity_stencil use MOM_CoriolisAdv, only : CorAdCalc, CoriolisAdv_init, CoriolisAdv_CS use MOM_debugging, only : check_redundant use MOM_grid, only : ocean_grid_type @@ -506,7 +506,7 @@ end subroutine register_restarts_dyn_unsplit_RK2 subroutine initialize_dyn_unsplit_RK2(u, v, h, Time, G, GV, US, param_file, diag, CS, & restart_CS, Accel_diag, Cont_diag, MIS, MEKE, & OBC, update_OBC_CSp, ALE_CSp, setVisc_CSp, & - visc, dirs, ntrunc) + visc, dirs, ntrunc, cont_stencil) type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type @@ -551,6 +551,8 @@ subroutine initialize_dyn_unsplit_RK2(u, v, h, Time, G, GV, US, param_file, diag integer, target, intent(inout) :: ntrunc !< A target for the variable !! that records the number of times the !! velocity is truncated (this should be 0). + integer, optional, intent(out) :: cont_stencil !< The stencil for + !! thickness from the continuity solver. ! This subroutine initializes all of the variables that are used by this ! dynamic core, including diagnostics and the cpu clocks. @@ -610,6 +612,7 @@ subroutine initialize_dyn_unsplit_RK2(u, v, h, Time, G, GV, US, param_file, diag Accel_diag%CAu => CS%CAu ; Accel_diag%CAv => CS%CAv call continuity_init(Time, G, GV, US, param_file, diag, CS%continuity_CSp) + if (present(cont_stencil)) cont_stencil = continuity_stencil(CS%continuity_CSp) call CoriolisAdv_init(Time, G, GV, US, param_file, diag, CS%ADp, CS%CoriolisAdv_CSp) if (use_tides) call tidal_forcing_init(Time, G, param_file, CS%tides_CSp) call PressureForce_init(Time, G, GV, US, param_file, diag, CS%PressureForce_CSp, & From 93fc4651642cbe894f9027983a0014b02e6cb061 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 5 Feb 2020 13:25:12 -0500 Subject: [PATCH 049/316] +(*)Added runtime parameter HOR_REGRID_2018_ANSWERS Added the new optional argument answers_2018 to horiz_interp_and_extrap_tracer and fill_miss_2d. If answers_2018 is present and false, new expressions that respect rotational symmetry are used in the interpolation to fill missing data. Also added the new runtime parameter HOR_REGRID_2018_ANSWERS to set the value of answers_2018 that is passed to these routines by MOM6. Also replaced the hard-coded value of the minimal-thickness eps_z with GV%Angstrom_Z in MOM_temp_salt_initialize_from_Z, but since the hard-coded value (1e-10 m) coincided with the value of Angstrom_Z used in relevant test cases, the answers do not change in any of the MOM6-examples test cases. By default, all answers are bitwise identical but there are new entries in some MOM_parameter_doc files. --- src/framework/MOM_horizontal_regridding.F90 | 58 ++++++++++++------- .../MOM_state_initialization.F90 | 17 +++--- .../MOM_tracer_initialization_from_Z.F90 | 12 ++-- .../vertical/MOM_ALE_sponge.F90 | 33 +++++++---- 4 files changed, 77 insertions(+), 43 deletions(-) diff --git a/src/framework/MOM_horizontal_regridding.F90 b/src/framework/MOM_horizontal_regridding.F90 index 0af2b1759b..a6cd8c048a 100644 --- a/src/framework/MOM_horizontal_regridding.F90 +++ b/src/framework/MOM_horizontal_regridding.F90 @@ -100,7 +100,7 @@ end subroutine myStats !! 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) +subroutine fill_miss_2d(aout, good, fill, prev, G, smooth, num_pass, relc, crit, debug, answers_2018) use MOM_coms, only : sum_across_PEs type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. @@ -119,9 +119,10 @@ subroutine fill_miss_2d(aout, good, fill, prev, G, smooth, num_pass, relc, crit, integer, optional, intent(in) :: num_pass !< The maximum number of iterations real, optional, intent(in) :: relc !< A relaxation coefficient for Laplacian (ND) real, optional, intent(in) :: crit !< A minimal value for deltas between iterations. - 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. + logical, optional, intent(in) :: answers_2018 !< If true, use expressions that give the same + !! answers as the code did in late 2018. Otherwise + !! add parentheses for rotational symmetry. real, dimension(SZI_(G),SZJ_(G)) :: b,r real, dimension(SZI_(G),SZJ_(G)) :: fill_pts, good_, good_new @@ -138,7 +139,7 @@ subroutine fill_miss_2d(aout, good, fill, prev, G, smooth, num_pass, relc, crit, integer :: npass integer :: is, ie, js, je real :: relax_coeff, acrit, ares - logical :: debug_it + logical :: debug_it, ans_2018 debug_it=.false. if (PRESENT(debug)) debug_it=debug @@ -154,12 +155,11 @@ subroutine fill_miss_2d(aout, good, fill, prev, G, smooth, num_pass, relc, crit, acrit = crit_default if (PRESENT(crit)) acrit = crit - siena_bug=.false. - if (PRESENT(keep_bug)) siena_bug = keep_bug - do_smooth=.false. if (PRESENT(smooth)) do_smooth=smooth + ans_2018 = .true. ; if (PRESENT(answers_2018)) ans_2018 = answers_2018 + fill_pts(:,:) = fill(:,:) nfill = sum(fill(is:ie,js:je)) @@ -189,11 +189,17 @@ subroutine fill_miss_2d(aout, good, fill, prev, G, smooth, num_pass, relc, crit, 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 (ans_2018) then + ngood = ge+gw+gn+gs + else + ngood = (ge+gw) + (gn+gs) + endif if (ngood > 0.) then - b(i,j)=(east+west+north+south)/ngood - !### Replace this with - ! b(i,j) = ((east+west) + (north+south))/ngood + if (ans_2018) then + b(i,j)=(east+west+north+south)/ngood + else + b(i,j) = ((east+west) + (north+south))/ngood + endif fill_pts(i,j) = 0.0 good_new(i,j) = 1.0 endif @@ -230,13 +236,15 @@ subroutine fill_miss_2d(aout, good, fill, prev, G, smooth, num_pass, relc, crit, 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)) - 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)) - !### 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) ) + if (ans_2018) then + 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) = 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) ) + endif else r(i,j) = 0. endif @@ -264,7 +272,7 @@ end subroutine fill_miss_2d !> Extrapolate and interpolate from a file record subroutine horiz_interp_and_extrap_tracer_record(filename, varnam, conversion, recnum, G, tr_z, & mask_z, z_in, z_edges_in, missing_value, reentrant_x, & - tripolar_n, homogenize, m_to_Z) + tripolar_n, homogenize, m_to_Z, answers_2018) character(len=*), intent(in) :: filename !< Path to file containing tracer to be !! interpolated. @@ -285,6 +293,9 @@ subroutine horiz_interp_and_extrap_tracer_record(filename, varnam, conversion, !! to produce perfectly "flat" initial conditions real, optional, intent(in) :: m_to_Z !< A conversion factor from meters to the units !! of depth. If missing, G%bathyT must be in m. + logical, optional, intent(in) :: answers_2018 !< If true, use expressions that give the same + !! answers as the code did in late 2018. Otherwise + !! add parentheses for rotational symmetry. ! Local variables real, dimension(:,:), allocatable :: tr_in, tr_inp ! A 2-d array for holding input data on @@ -568,7 +579,7 @@ subroutine horiz_interp_and_extrap_tracer_record(filename, varnam, conversion, good2(:,:) = good(:,:) fill2(:,:) = fill(:,:) - call fill_miss_2d(tr_outf, good2, fill2, tr_prev, G, smooth=.true.) + call fill_miss_2d(tr_outf, good2, fill2, tr_prev, G, smooth=.true., answers_2018=answers_2018) call myStats(tr_outf, missing_value, is, ie, js, je, k, 'field from fill_miss_2d()') tr_z(:,:,k) = tr_outf(:,:) * G%mask2dT(:,:) @@ -587,7 +598,7 @@ end subroutine horiz_interp_and_extrap_tracer_record !> Extrapolate and interpolate using a FMS time interpolation handle subroutine horiz_interp_and_extrap_tracer_fms_id(fms_id, Time, conversion, G, tr_z, mask_z, & z_in, z_edges_in, missing_value, reentrant_x, & - tripolar_n, homogenize, spongeOngrid, m_to_Z) + tripolar_n, homogenize, spongeOngrid, m_to_Z, answers_2018) integer, intent(in) :: fms_id !< A unique id used by the FMS time interpolator type(time_type), intent(in) :: Time !< A FMS time type @@ -607,6 +618,9 @@ subroutine horiz_interp_and_extrap_tracer_fms_id(fms_id, Time, conversion, G, t logical, optional, intent(in) :: spongeOngrid !< If present and true, the sponge data are on the model grid real, optional, intent(in) :: m_to_Z !< A conversion factor from meters to the units !! of depth. If missing, G%bathyT must be in m. + logical, optional, intent(in) :: answers_2018 !< If true, use expressions that give the same + !! answers as the code did in late 2018. Otherwise + !! add parentheses for rotational symmetry. ! Local variables real, dimension(:,:), allocatable :: tr_in,tr_inp !< A 2-d array for holding input data on @@ -841,7 +855,7 @@ subroutine horiz_interp_and_extrap_tracer_fms_id(fms_id, Time, conversion, G, t good2(:,:) = good(:,:) fill2(:,:) = fill(:,:) - call fill_miss_2d(tr_outf, good2, fill2, tr_prev, G, smooth=.true.) + call fill_miss_2d(tr_outf, good2, fill2, tr_prev, G, smooth=.true., answers_2018=answers_2018) ! if (debug) then ! call hchksum(tr_outf, 'field from fill_miss_2d ', G%HI) diff --git a/src/initialization/MOM_state_initialization.F90 b/src/initialization/MOM_state_initialization.F90 index d951be33c0..ed6aa5a44d 100644 --- a/src/initialization/MOM_state_initialization.F90 +++ b/src/initialization/MOM_state_initialization.F90 @@ -2034,7 +2034,7 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, G, GV, US, PF, just_read_param type(remapping_CS) :: remapCS ! Remapping parameters and work arrays logical :: homogenize, useALEremapping, remap_full_column, remap_general, remap_old_alg - logical :: answers_2018, default_2018_answers + logical :: answers_2018, default_2018_answers, hor_regrid_answers_2018 logical :: use_ice_shelf character(len=10) :: remappingScheme real :: tempAvg, saltAvg @@ -2112,15 +2112,19 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, G, GV, US, PF, just_read_param "If false, uses the preferred remapping algorithm for initialization. "//& "If true, use an older, less robust algorithm for remapping.", & default=.true., do_not_log=just_read) - if (useALEremapping) then - call get_param(PF, mdl, "DEFAULT_2018_ANSWERS", default_2018_answers, & + call get_param(PF, mdl, "DEFAULT_2018_ANSWERS", default_2018_answers, & "This sets the default value for the various _2018_ANSWERS parameters.", & default=.true.) + if (useALEremapping) then call get_param(PF, mdl, "REMAPPING_2018_ANSWERS", answers_2018, & "If true, use the order of arithmetic and expressions that recover the "//& "answers from the end of 2018. Otherwise, use updated and more robust "//& "forms of the same expressions.", default=default_2018_answers) endif + call get_param(PF, mdl, "HOR_REGRID_2018_ANSWERS", hor_regrid_answers_2018, & + "If true, use the order of arithmetic for horizonal regridding that recovers "//& + "the answers from the end of 2018. Otherwise, use rotationally symmetric "//& + "forms of the same expressions.", default=default_2018_answers) call get_param(PF, mdl, "ICE_SHELF", use_ice_shelf, default=.false.) if (use_ice_shelf) then call get_param(PF, mdl, "ICE_THICKNESS_FILE", ice_shelf_file, & @@ -2149,8 +2153,7 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, G, GV, US, PF, just_read_param return ! All run-time parameters have been read, so return. endif - !### Change this to GV%Angstrom_Z - eps_z = 1.0e-10*US%m_to_Z + eps_z = GV%Angstrom_Z eps_rho = 1.0e-10*US%kg_m3_to_R ! Read input grid coordinates for temperature and salinity field @@ -2170,11 +2173,11 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, G, GV, US, PF, just_read_param call horiz_interp_and_extrap_tracer(tfilename, potemp_var, 1.0, 1, & G, temp_z, mask_z, z_in, z_edges_in, missing_value_temp, reentrant_x, & - tripolar_n, homogenize, m_to_Z=US%m_to_Z) + tripolar_n, homogenize, m_to_Z=US%m_to_Z, answers_2018=hor_regrid_answers_2018) call horiz_interp_and_extrap_tracer(sfilename, salin_var, 1.0, 1, & G, salt_z, mask_z, z_in, z_edges_in, missing_value_salt, reentrant_x, & - tripolar_n, homogenize, m_to_Z=US%m_to_Z) + tripolar_n, homogenize, m_to_Z=US%m_to_Z, answers_2018=hor_regrid_answers_2018) kd = size(z_in,1) diff --git a/src/initialization/MOM_tracer_initialization_from_Z.F90 b/src/initialization/MOM_tracer_initialization_from_Z.F90 index bbe61892b2..5d585466c8 100644 --- a/src/initialization/MOM_tracer_initialization_from_Z.F90 +++ b/src/initialization/MOM_tracer_initialization_from_Z.F90 @@ -90,7 +90,7 @@ subroutine MOM_initialize_tracer_from_Z(h, tr, G, GV, US, PF, src_file, src_var_ real :: missing_value integer :: nPoints integer :: id_clock_routine, id_clock_ALE - logical :: answers_2018, default_2018_answers + logical :: answers_2018, default_2018_answers, hor_regrid_answers_2018 logical :: reentrant_x, tripolar_n id_clock_routine = cpu_clock_id('(Initialize tracer from Z)', grain=CLOCK_ROUTINE) @@ -112,15 +112,19 @@ subroutine MOM_initialize_tracer_from_Z(h, tr, G, GV, US, PF, src_file, src_var_ call get_param(PF, mdl, "Z_INIT_REMAPPING_SCHEME", remapScheme, & "The remapping scheme to use if using Z_INIT_ALE_REMAPPING is True.", & default="PLM") - if (useALE) then - call get_param(PF, mdl, "DEFAULT_2018_ANSWERS", default_2018_answers, & + call get_param(PF, mdl, "DEFAULT_2018_ANSWERS", default_2018_answers, & "This sets the default value for the various _2018_ANSWERS parameters.", & default=.true.) + if (useALE) then call get_param(PF, mdl, "REMAPPING_2018_ANSWERS", answers_2018, & "If true, use the order of arithmetic and expressions that recover the "//& "answers from the end of 2018. Otherwise, use updated and more robust "//& "forms of the same expressions.", default=default_2018_answers) endif + call get_param(PF, mdl, "HOR_REGRID_2018_ANSWERS", hor_regrid_answers_2018, & + "If true, use the order of arithmetic for horizonal regridding that recovers "//& + "the answers from the end of 2018. Otherwise, use rotationally symmetric "//& + "forms of the same expressions.", default=default_2018_answers) ! These are model grid properties, but being applied to the data grid for now. ! need to revisit this (mjh) @@ -137,7 +141,7 @@ subroutine MOM_initialize_tracer_from_Z(h, tr, G, GV, US, PF, src_file, src_var_ call horiz_interp_and_extrap_tracer(src_file, src_var_nam, convert, recnum, & G, tr_z, mask_z, z_in, z_edges_in, missing_value, reentrant_x, tripolar_n, & - homog, m_to_Z=US%m_to_Z) + homog, m_to_Z=US%m_to_Z, answers_2018=hor_regrid_answers_2018) kd = size(z_edges_in,1)-1 call pass_var(tr_z,G%Domain) diff --git a/src/parameterizations/vertical/MOM_ALE_sponge.F90 b/src/parameterizations/vertical/MOM_ALE_sponge.F90 index b19f81f8d1..ccd85280f5 100644 --- a/src/parameterizations/vertical/MOM_ALE_sponge.F90 +++ b/src/parameterizations/vertical/MOM_ALE_sponge.F90 @@ -130,6 +130,9 @@ module MOM_ALE_sponge logical :: remap_answers_2018 !< If true, use the order of arithmetic and expressions that !! recover the answers for remapping from the end of 2018. !! Otherwise, use more robust forms of the same expressions. + logical :: hor_regrid_answers_2018 !< If true, use the order of arithmetic for horizonal regridding + !! that recovers the answers from the end of 2018. Otherwise, use + !! rotationally symmetric forms of the same expressions. logical :: time_varying_sponges !< True if using newer sponge code logical :: spongeDataOngrid !< True if the sponge data are on the model horizontal grid @@ -204,6 +207,10 @@ subroutine initialize_ALE_sponge_fixed(Iresttime, G, param_file, CS, data_h, nz_ "If true, use the order of arithmetic and expressions that recover the "//& "answers from the end of 2018. Otherwise, use updated and more robust "//& "forms of the same expressions.", default=default_2018_answers) + call get_param(param_file, mdl, "HOR_REGRID_2018_ANSWERS", CS%hor_regrid_answers_2018, & + "If true, use the order of arithmetic for horizonal regridding that recovers "//& + "the answers from the end of 2018. Otherwise, use rotationally symmetric "//& + "forms of the same expressions.", default=default_2018_answers) CS%time_varying_sponges = .false. CS%nz = G%ke @@ -742,15 +749,17 @@ subroutine set_up_ALE_sponge_vel_field_varying(filename_u, fieldname_u, filename ! I am hard-wiring this call to assume that the input grid is zonally re-entrant ! In the future, this should be generalized using an interface to return the ! modulo attribute of the zonal axis (mjh). - call horiz_interp_and_extrap_tracer(CS%Ref_val_u%id,Time, 1.0,G,u_val,mask_u,z_in,z_edges_in,& - missing_value,.true.,.false.,.false., m_to_Z=US%m_to_Z) + call horiz_interp_and_extrap_tracer(CS%Ref_val_u%id, Time, 1.0, G, u_val, mask_u, z_in, z_edges_in, & + missing_value, .true., .false., .false., m_to_Z=US%m_to_Z, & + answers_2018=CS%hor_regrid_answers_2018) !!! TODO: add a velocity interface! (mjh) ! Interpolate external file data to the model grid ! I am hard-wiring this call to assume that the input grid is zonally re-entrant ! In the future, this should be generalized using an interface to return the ! modulo attribute of the zonal axis (mjh). - call horiz_interp_and_extrap_tracer(CS%Ref_val_v%id,Time, 1.0,G,v_val,mask_v,z_in,z_edges_in, & - missing_value,.true.,.false.,.false., m_to_Z=US%m_to_Z) + call horiz_interp_and_extrap_tracer(CS%Ref_val_v%id, Time, 1.0, G, v_val, mask_v, z_in, z_edges_in, & + missing_value, .true., .false., .false., m_to_Z=US%m_to_Z, & + answers_2018=CS%hor_regrid_answers_2018) ! stores the reference profile allocate(CS%Ref_val_u%p(fld_sz(3),CS%num_col_u)) CS%Ref_val_u%p(:,:) = 0.0 @@ -824,8 +833,10 @@ subroutine apply_ALE_sponge(h, dt, G, GV, US, CS, Time) allocate(mask_z(G%isd:G%ied,G%jsd:G%jed,1:nz_data)) sp_val(:,:,:)=0.0 mask_z(:,:,:)=0.0 - call horiz_interp_and_extrap_tracer(CS%Ref_val(m)%id,Time, 1.0,G,sp_val,mask_z,z_in,z_edges_in, & - missing_value,.true., .false.,.false.,spongeOnGrid=CS%SpongeDataOngrid, m_to_Z=US%m_to_Z) + call horiz_interp_and_extrap_tracer(CS%Ref_val(m)%id, Time, 1.0, G, sp_val, mask_z, z_in, & + z_edges_in, missing_value, .true., .false., .false., & + spongeOnGrid=CS%SpongeDataOngrid, m_to_Z=US%m_to_Z, & + answers_2018=CS%hor_regrid_answers_2018) allocate( hsrc(nz_data) ) allocate( tmpT1d(nz_data) ) do c=1,CS%num_col @@ -906,8 +917,9 @@ subroutine apply_ALE_sponge(h, dt, G, GV, US, CS, Time) allocate(sp_val(G%isdB:G%iedB,G%jsd:G%jed,1:nz_data)) allocate(mask_z(G%isdB:G%iedB,G%jsd:G%jed,1:nz_data)) ! Interpolate from the external horizontal grid and in time - call horiz_interp_and_extrap_tracer(CS%Ref_val_u%id,Time, 1.0,G,sp_val,mask_z,z_in,z_edges_in, & - missing_value, .true., .false., .false., m_to_Z=US%m_to_Z) + call horiz_interp_and_extrap_tracer(CS%Ref_val_u%id, Time, 1.0, G, sp_val, mask_z, z_in, & + z_edges_in, missing_value, .true., .false., .false., & + m_to_Z=US%m_to_Z, answers_2018=CS%hor_regrid_answers_2018) ! call pass_var(sp_val,G%Domain) ! call pass_var(mask_z,G%Domain) do c=1,CS%num_col @@ -923,8 +935,9 @@ subroutine apply_ALE_sponge(h, dt, G, GV, US, CS, Time) allocate(sp_val(G%isd:G%ied,G%jsdB:G%jedB,1:nz_data)) allocate(mask_z(G%isd:G%ied,G%jsdB:G%jedB,1:nz_data)) ! Interpolate from the external horizontal grid and in time - call horiz_interp_and_extrap_tracer(CS%Ref_val_v%id,Time, 1.0,G,sp_val,mask_z,z_in,z_edges_in, & - missing_value, .true., .false., .false., m_to_Z=US%m_to_Z) + call horiz_interp_and_extrap_tracer(CS%Ref_val_v%id, Time, 1.0, G, sp_val, mask_z, z_in, & + z_edges_in, missing_value, .true., .false., .false., & + m_to_Z=US%m_to_Z, answers_2018=CS%hor_regrid_answers_2018) ! call pass_var(sp_val,G%Domain) ! call pass_var(mask_z,G%Domain) From 4d245d6b7448182c38c737a2e2f558f3965e692a Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Wed, 5 Feb 2020 13:59:46 -0500 Subject: [PATCH 050/316] Segment index added for several OBC segment flags In setup_[uv]_point_obc, a number of flags for each segment were assigned without index (OBC%segment%flag), which was causing all segments to be assigned the same value. This could problems with, say, `[uv]_value_needed` flags, which have different values depending on if they are E-W or N-S oriented. This patch adds the index to the assignments. --- src/core/MOM_open_boundary.F90 | 32 ++++++++++++++++---------------- 1 file changed, 16 insertions(+), 16 deletions(-) diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index 822ca6486f..2fdfad4b59 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -904,8 +904,8 @@ subroutine setup_u_point_obc(OBC, G, US, segment_str, l_seg, PF, reentrant_y) OBC%segment(l_seg)%open = .true. OBC%Flather_u_BCs_exist_globally = .true. OBC%open_u_BCs_exist_globally = .true. - OBC%segment%z_values_needed = .true. - OBC%segment%u_values_needed = .true. + OBC%segment(l_seg)%z_values_needed = .true. + OBC%segment(l_seg)%u_values_needed = .true. elseif (trim(action_str(a_loop)) == 'ORLANSKI') then OBC%segment(l_seg)%radiation = .true. OBC%segment(l_seg)%open = .true. @@ -933,14 +933,14 @@ subroutine setup_u_point_obc(OBC, G, US, segment_str, l_seg, PF, reentrant_y) elseif (trim(action_str(a_loop)) == 'NUDGED') then OBC%segment(l_seg)%nudged = .true. OBC%nudged_u_BCs_exist_globally = .true. - OBC%segment%u_values_needed = .true. + OBC%segment(l_seg)%u_values_needed = .true. elseif (trim(action_str(a_loop)) == 'NUDGED_TAN') then OBC%segment(l_seg)%nudged_tan = .true. OBC%nudged_u_BCs_exist_globally = .true. - OBC%segment%v_values_needed = .true. + OBC%segment(l_seg)%v_values_needed = .true. elseif (trim(action_str(a_loop)) == 'NUDGED_GRAD') then OBC%segment(l_seg)%nudged_grad = .true. - OBC%segment%g_values_needed = .true. + OBC%segment(l_seg)%g_values_needed = .true. elseif (trim(action_str(a_loop)) == 'GRADIENT') then OBC%segment(l_seg)%gradient = .true. OBC%segment(l_seg)%open = .true. @@ -948,13 +948,13 @@ subroutine setup_u_point_obc(OBC, G, US, segment_str, l_seg, PF, reentrant_y) elseif (trim(action_str(a_loop)) == 'SIMPLE') then OBC%segment(l_seg)%specified = .true. OBC%specified_u_BCs_exist_globally = .true. ! This avoids deallocation - OBC%segment%u_values_needed = .true. + OBC%segment(l_seg)%u_values_needed = .true. elseif (trim(action_str(a_loop)) == 'SIMPLE_TAN') then OBC%segment(l_seg)%specified_tan = .true. - OBC%segment%v_values_needed = .true. + OBC%segment(l_seg)%v_values_needed = .true. elseif (trim(action_str(a_loop)) == 'SIMPLE_GRAD') then OBC%segment(l_seg)%specified_grad = .true. - OBC%segment%g_values_needed = .true. + OBC%segment(l_seg)%g_values_needed = .true. else call MOM_error(FATAL, "MOM_open_boundary.F90, setup_u_point_obc: "//& "String '"//trim(action_str(a_loop))//"' not understood.") @@ -1045,8 +1045,8 @@ subroutine setup_v_point_obc(OBC, G, US, segment_str, l_seg, PF, reentrant_x) OBC%segment(l_seg)%open = .true. OBC%Flather_v_BCs_exist_globally = .true. OBC%open_v_BCs_exist_globally = .true. - OBC%segment%z_values_needed = .true. - OBC%segment%v_values_needed = .true. + OBC%segment(l_seg)%z_values_needed = .true. + OBC%segment(l_seg)%v_values_needed = .true. elseif (trim(action_str(a_loop)) == 'ORLANSKI') then OBC%segment(l_seg)%radiation = .true. OBC%segment(l_seg)%open = .true. @@ -1074,14 +1074,14 @@ subroutine setup_v_point_obc(OBC, G, US, segment_str, l_seg, PF, reentrant_x) elseif (trim(action_str(a_loop)) == 'NUDGED') then OBC%segment(l_seg)%nudged = .true. OBC%nudged_v_BCs_exist_globally = .true. - OBC%segment%v_values_needed = .true. + OBC%segment(l_seg)%v_values_needed = .true. elseif (trim(action_str(a_loop)) == 'NUDGED_TAN') then OBC%segment(l_seg)%nudged_tan = .true. OBC%nudged_v_BCs_exist_globally = .true. - OBC%segment%u_values_needed = .true. + OBC%segment(l_seg)%u_values_needed = .true. elseif (trim(action_str(a_loop)) == 'NUDGED_GRAD') then OBC%segment(l_seg)%nudged_grad = .true. - OBC%segment%g_values_needed = .true. + OBC%segment(l_seg)%g_values_needed = .true. elseif (trim(action_str(a_loop)) == 'GRADIENT') then OBC%segment(l_seg)%gradient = .true. OBC%segment(l_seg)%open = .true. @@ -1089,13 +1089,13 @@ subroutine setup_v_point_obc(OBC, G, US, segment_str, l_seg, PF, reentrant_x) elseif (trim(action_str(a_loop)) == 'SIMPLE') then OBC%segment(l_seg)%specified = .true. OBC%specified_v_BCs_exist_globally = .true. ! This avoids deallocation - OBC%segment%v_values_needed = .true. + OBC%segment(l_seg)%v_values_needed = .true. elseif (trim(action_str(a_loop)) == 'SIMPLE_TAN') then OBC%segment(l_seg)%specified_tan = .true. - OBC%segment%u_values_needed = .true. + OBC%segment(l_seg)%u_values_needed = .true. elseif (trim(action_str(a_loop)) == 'SIMPLE_GRAD') then OBC%segment(l_seg)%specified_grad = .true. - OBC%segment%g_values_needed = .true. + OBC%segment(l_seg)%g_values_needed = .true. else call MOM_error(FATAL, "MOM_open_boundary.F90, setup_v_point_obc: "//& "String '"//trim(action_str(a_loop))//"' not understood.") From 378a02c597ab4f13bf2fa0e017267f44203b5f6e Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 5 Feb 2020 15:38:54 -0500 Subject: [PATCH 051/316] Started refactoring determine_temperature Fixed dimensionally inconsistent expressions in the determine_temperature routine of midas_vertmap. Thankfully this code had been hard-coded not to be used, so no answers are changed. This routine should be carefully reevaluated and refactored further, as it uses many hard-coded dimensional constants and is probably not ideal for what it does. For now, though, all answers are bitwise identical. --- src/initialization/midas_vertmap.F90 | 46 +++++++++++++++------------- 1 file changed, 25 insertions(+), 21 deletions(-) diff --git a/src/initialization/midas_vertmap.F90 b/src/initialization/midas_vertmap.F90 index f33d476cf0..4bc7ed6707 100644 --- a/src/initialization/midas_vertmap.F90 +++ b/src/initialization/midas_vertmap.F90 @@ -24,9 +24,6 @@ module MIDAS_vertmap module procedure fill_boundaries_int end interface -! real, parameter :: epsln=1.e-10 !< A hard-wired constant! - !! \todo Get rid of this constant - contains #ifdef PY_SOLO @@ -378,14 +375,22 @@ subroutine determine_temperature(temp, salt, R, p_ref, niter, land_fill, h, k_st real(kind=8), dimension(size(temp,1),size(temp,3)) :: drho_dT, drho_dS real(kind=8), dimension(size(temp,1)) :: press integer :: nx, ny, nz, nt, i, j, k, n, itt - real :: dT_dS + real :: dT_dS_gauge ! The relative penalizing of temperature to salinity changes when + ! minimizing property changes while correcting density [degC ppt-1]. + real :: I_denom ! The inverse of the magnitude squared of the density gradient in + ! T-S space streched with dT_dS_gauge [m6 kg-2 ppt-1] logical :: adjust_salt, old_fit real, parameter :: S_min = 0.5, S_max=65.0 - real, parameter :: tol=1.e-4, max_t_adj=1.0, max_s_adj = 0.5 + real, parameter :: tol_T=1.e-4, tol_S=1.e-4, tol_rho=1.e-4 + real, parameter :: max_t_adj=1.0, max_s_adj = 0.5 old_fit = .true. ! reproduces siena behavior - ! will switch to the newer method which simultaneously adjusts - ! temp and salt based on the ratio of the thermal and haline coefficients. + + ! ### The whole determine_temperature subroutine needs to be reexamined, both the algorithms + ! and the extensive use of hard-coded dimensional parameters. + + ! We will switch to the newer method which simultaneously adjusts + ! temp and salt based on the ratio of the thermal and haline coefficients, once it is tested. nx=size(temp,1) ; ny=size(temp,2) ; nz=size(temp,3) @@ -411,23 +416,22 @@ subroutine determine_temperature(temp, salt, R, p_ref, niter, land_fill, h, k_st do k=k_start,nz ; do i=1,nx ! if (abs(rho(i,k)-R(k))>tol .and. hin(i,k)>epsln .and. abs(T(i,k)-land_fill) < epsln) then - if (abs(rho(i,k)-R(k))>tol) then + if (abs(rho(i,k)-R(k))>tol_rho) then if (old_fit) then - dT(i,k) = max(min((R(k)-rho(i,k)) / drho_dT(i,k), max_t_adj), -max_t_adj) - T(i,k) = max(min(T(i,k)+dT(i,k), T_max), T_min) + dT(i,k) = max(min((R(k)-rho(i,k)) / drho_dT(i,k), max_t_adj), -max_t_adj) + T(i,k) = max(min(T(i,k)+dT(i,k), T_max), T_min) else - dT_dS = 10.0 - min(-drho_dT(i,k)/drho_dS(i,k),10.) - !### RWH: Based on the dimensions alone, the expression above should be: - ! dT_dS = 10.0 - min(-drho_dS(i,k)/drho_dT(i,k),10.) - dS(i,k) = (R(k)-rho(i,k)) / (drho_dS(i,k) - drho_dT(i,k)*dT_dS ) - dT(i,k) = -dT_dS*dS(i,k) - ! dT(i,k) = max(min(dT(i,k), max_t_adj), -max_t_adj) - T(i,k) = max(min(T(i,k)+dT(i,k), T_max), T_min) - S(i,k) = max(min(S(i,k)+dS(i,k), S_max), S_min) + dT_dS_gauge = 10.0 ! 10 degC is weighted equivalently to 1 ppt. + I_denom = 1.0 / (drho_dS(i,k)**2 + dT_dS_gauge**2*drho_dT(i,k)**2) + dS(i,k) = (R(k)-rho(i,k)) * drho_dS(i,k) * I_denom + dT(i,k) = (R(k)-rho(i,k)) * dT_dS_gauge**2*drho_dT(i,k) * I_denom + + T(i,k) = max(min(T(i,k)+dT(i,k), T_max), T_min) + S(i,k) = max(min(S(i,k)+dS(i,k), S_max), S_min) endif endif enddo ; enddo - if (maxval(abs(dT)) < tol) then + if (maxval(abs(dT)) < tol_T) then adjust_salt = .false. exit iter_loop endif @@ -445,12 +449,12 @@ subroutine determine_temperature(temp, salt, R, p_ref, niter, land_fill, h, k_st #endif do k=k_start,nz ; do i=1,nx ! if (abs(rho(i,k)-R(k))>tol .and. hin(i,k)>epsln .and. abs(T(i,k)-land_fill) < epsln ) then - if (abs(rho(i,k)-R(k)) > tol) then + if (abs(rho(i,k)-R(k)) > tol_rho) then dS(i,k) = max(min((R(k)-rho(i,k)) / drho_dS(i,k), max_s_adj), -max_s_adj) S(i,k) = max(min(S(i,k)+dS(i,k), S_max), S_min) endif enddo ; enddo - if (maxval(abs(dS)) < tol) exit + if (maxval(abs(dS)) < tol_S) exit enddo ; endif temp(:,j,:)=T(:,:) From f6da690428282a23c2d20639d3142f8817edcaa0 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 5 Feb 2020 18:52:26 -0500 Subject: [PATCH 052/316] (*)Average Stokes drifts over accumulated depths Average Stokes drifts over actual depth of the ocean if it is less than the averaging depth. This is not the case in any of the current test case, so answers do not change. Also removed two other notes in comments and added proper dimensional rescaling of one variable in an unused section of the code. All answers in the test cases are bitwise identical. --- src/user/MOM_wave_interface.F90 | 29 +++++++++++++++++++---------- 1 file changed, 19 insertions(+), 10 deletions(-) diff --git a/src/user/MOM_wave_interface.F90 b/src/user/MOM_wave_interface.F90 index a048d85491..e7361bf13c 100644 --- a/src/user/MOM_wave_interface.F90 +++ b/src/user/MOM_wave_interface.F90 @@ -653,7 +653,8 @@ subroutine Update_Stokes_Drift(G, GV, US, CS, h, ustar) ! uniform cases. ! call DHH85_mid(GV, US, Midpoint, UStokes) ! Putting into x-direction, so setting y direction to 0 - CS%US_y(ii,JJ,kk) = 0.0 !### Note that =0 should be =US - RWH + CS%US_y(ii,JJ,kk) = 0.0 + ! For rotational symmetry there should be the option for this to become = UStokes ! bgr - see note above, but this is true ! if this is used for anything ! other than simple LES comparison @@ -1081,7 +1082,7 @@ end subroutine Get_StokesSL_LiFoxKemper subroutine Get_SL_Average_Prof( GV, AvgDepth, H, Profile, Average ) type(verticalGrid_type), & intent(in) :: GV !< Ocean vertical grid structure - real, intent(in) :: AvgDepth !< Depth to average over [Z ~> m]. + real, intent(in) :: AvgDepth !< Depth to average over (negative) [Z ~> m]. real, dimension(SZK_(GV)), & intent(in) :: H !< Grid thickness [H ~> m or kg m-2] real, dimension(SZK_(GV)), & @@ -1090,7 +1091,7 @@ subroutine Get_SL_Average_Prof( GV, AvgDepth, H, Profile, Average ) real, intent(out) :: Average !< Output quantity averaged over depth AvgDepth [arbitrary] !! (used here for Stokes drift) !Local variables - real :: top, midpoint, bottom ! Depths [Z ~> m]. + real :: top, midpoint, bottom ! Depths, negative downward [Z ~> m]. real :: Sum integer :: kk @@ -1103,17 +1104,25 @@ subroutine Get_SL_Average_Prof( GV, AvgDepth, H, Profile, Average ) Top = Bottom MidPoint = Bottom - GV%H_to_Z * 0.5*h(kk) Bottom = Bottom - GV%H_to_Z * h(kk) - if (AvgDepth < Bottom) then !Whole cell within H_LA + if (AvgDepth < Bottom) then ! The whole cell is within H_LA Sum = Sum + Profile(kk) * (GV%H_to_Z * H(kk)) - elseif (AvgDepth < Top) then !partial cell within H_LA + elseif (AvgDepth < Top) then ! A partial cell is within H_LA Sum = Sum + Profile(kk) * (Top-AvgDepth) + exit + else + exit endif enddo - ! Divide by AvgDepth !### Consider dividing by the depth in the column if that is smaller. -RWH - Average = Sum / abs(AvgDepth) + ! Divide by AvgDepth or the depth in the column, whichever is smaller. + if (abs(AvgDepth) <= abs(Bottom)) then + Average = Sum / abs(AvgDepth) + elseif (abs(Bottom) > 0.0) then + Average = Sum / abs(Bottom) + else + Average = 0.0 + endif - return end subroutine Get_SL_Average_Prof !> Get SL averaged Stokes drift from the banded Spectrum method @@ -1153,7 +1162,7 @@ end subroutine Get_SL_Average_Band subroutine DHH85_mid(GV, US, zpt, UStokes) type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - real, intent(in) :: ZPT !< Depth to get Stokes drift [Z ~> m]. !### THIS IS NOT USED YET. + real, intent(in) :: zpt !< Depth to get Stokes drift [Z ~> m]. real, intent(out) :: UStokes !< Stokes drift [m s-1] ! real :: ann, Bnn, Snn, Cnn, Dnn @@ -1195,7 +1204,7 @@ subroutine DHH85_mid(GV, US, zpt, UStokes) exp(-bnn*(omega_peak/omega)**4)*Cnn**Dnn ! Stokes units m (multiply by frequency range for units of m/s) Stokes = 2.0 * wavespec * omega**3 * & - exp( 2.0 * omega**2 * zpt / GV%mks_g_Earth) / GV%mks_g_Earth + exp( 2.0 * omega**2 * US%Z_to_m*zpt / GV%mks_g_Earth) / GV%mks_g_Earth UStokes = UStokes + Stokes*domega omega = omega + domega enddo From b9a5e7b328f89668f1a175ec4198a20ee171d314 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 6 Feb 2020 18:46:08 -0500 Subject: [PATCH 053/316] (*)Rescaled FLUXCONST during get_param Merged conversion of FLUXCONST parameters from day-1 to s-1 into scale arguments on their get_param calls. All answers in the MOM6-examples test cases are bitwise identical, although it is possible that in some configurations with RESTOREBUOY=True there could be changes at roundoff. --- config_src/solo_driver/MOM_surface_forcing.F90 | 15 ++++----------- 1 file changed, 4 insertions(+), 11 deletions(-) diff --git a/config_src/solo_driver/MOM_surface_forcing.F90 b/config_src/solo_driver/MOM_surface_forcing.F90 index 56d7d5a846..a113d18871 100644 --- a/config_src/solo_driver/MOM_surface_forcing.F90 +++ b/config_src/solo_driver/MOM_surface_forcing.F90 @@ -381,7 +381,6 @@ subroutine wind_forcing_const(sfc_state, forces, tau_x0, tau_y0, day, G, US, CS) Pa_conversion = US%kg_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z !set steady surface wind stresses, in units of Pa. - !### mag_tau = US%kg_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z * sqrt( tau_x0**2 + tau_y0**2) mag_tau = Pa_conversion * sqrt( tau_x0**2 + tau_y0**2) do j=js,je ; do I=is-1,Ieq @@ -1674,11 +1673,12 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, tracer_flow_C call get_param(param_file, mdl, "LATENT_HEAT_VAPORIZATION", CS%latent_heat_vapor, & "The latent heat of fusion.", units="J/kg", default=hlv) if (CS%restorebuoy) then + ! These three variables use non-standard time units, but are rescaled as they are read. call get_param(param_file, mdl, "FLUXCONST", CS%Flux_const, & "The constant that relates the restoring surface fluxes "//& "to the relative surface anomalies (akin to a piston "//& "velocity). Note the non-MKS units.", & - units="m day-1", scale=US%m_to_Z*US%T_to_s, & + units="m day-1", scale=US%m_to_Z*US%T_to_s/86400.0, & fail_if_missing=.true., unscaled=flux_const_default) if (CS%use_temperature) then @@ -1686,23 +1686,16 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, tracer_flow_C "The constant that relates the restoring surface temperature "//& "flux to the relative surface anomaly (akin to a piston "//& "velocity). Note the non-MKS units.", & - units="m day-1", scale=1.0, & ! scale=US%m_to_Z*US%T_to_s, + units="m day-1", scale=1.0/86400.0, & ! scale=US%m_to_Z*US%T_to_s, default=flux_const_default) call get_param(param_file, mdl, "FLUXCONST_S", CS%Flux_const_S, & "The constant that relates the restoring surface salinity "//& "flux to the relative surface anomaly (akin to a piston "//& "velocity). Note the non-MKS units.", & - units="m day-1", scale=US%m_to_Z*US%T_to_s, & + units="m day-1", scale=US%m_to_Z*US%T_to_s/86400.0, & default=flux_const_default) endif - !### Convert flux constants from m day-1 to m s-1. Folding these into the scaling - ! factors above could change a division into a multiply by a reciprocal, which could - ! change answers at the level of roundoff. - CS%Flux_const = CS%Flux_const / 86400.0 - CS%Flux_const_T = CS%Flux_const_T / 86400.0 - CS%Flux_const_S = CS%Flux_const_S / 86400.0 - if (trim(CS%buoy_config) == "linear") then call get_param(param_file, mdl, "SST_NORTH", CS%T_north, & "With buoy_config linear, the sea surface temperature "//& From 01318a8c4d73af5484e145802e7e4a25099d0b7e Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sat, 8 Feb 2020 10:34:54 -0500 Subject: [PATCH 054/316] +Added multiple options for the barotropic solver Added several new runtime parameters for the barotropic solver, including BT_NONLIN_STRESS, LINEARIZED_BT_CORIOLIS, BAROTROPIC_ANSWERS_2018, MEAN_SL and BT_CORIOLIS_SCALE, along with the new functions find_duhbt_du and find_dvhbt_dv. Also added warning messages if the barotropic free surface drops below the bathymetry. By default all answers are bitwise identical, but there are new entries in the MOM_parameter_doc files. --- src/core/MOM_barotropic.F90 | 378 ++++++++++++++++++++++++++---------- 1 file changed, 274 insertions(+), 104 deletions(-) diff --git a/src/core/MOM_barotropic.F90 b/src/core/MOM_barotropic.F90 index 14fc918b60..4407932f3a 100644 --- a/src/core/MOM_barotropic.F90 +++ b/src/core/MOM_barotropic.F90 @@ -203,8 +203,16 @@ module MOM_barotropic !! (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. + !! old and new velocities, with weights of (1-BEBT) and BEBT. + logical :: nonlin_stress !< If true, use the full depth of the ocean at the start of the + !! barotropic step when calculating the surface stress contribution to + !! the barotropic acclerations. Otherwise use the depth based on bathyT. + real :: BT_Coriolis_scale !< A factor by which the barotropic Coriolis acceleration anomaly + !! terms are scaled. + logical :: answers_2018 !< If true, use expressions for the barotropic solver that recover + !! the answers from the end of 2018. Otherwise, use more efficient + !! or general expressions. + 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 @@ -229,6 +237,8 @@ module MOM_barotropic logical :: linearized_BT_PV !< If true, the PV and interface thicknesses used !! in the barotropic Coriolis calculation is time !! invariant and linearized. + real :: mean_SL !< A mean sea level that is added to bathyT when + !! linearized_BT_PV is true [Z ~> m] 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 @@ -327,6 +337,7 @@ module MOM_barotropic real :: uh_WW !< The zonal transport when ubt=ubt_WW [H L2 T-1 ~> m3 s-1 or kg s-1]. real :: uh_EE !< The zonal transport when ubt=ubt_EE [H L2 T-1 ~> m3 s-1 or kg s-1]. end type local_BT_cont_u_type + !> A desciption of the functional dependence of transport at a v-point type, private :: local_BT_cont_v_type real :: FA_v_NN !< The effective open face area for meridional barotropic transport @@ -476,7 +487,8 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, ! relative to eta_PF, with SAL effects included [H ~> m or kg m-2]. ! These are always allocated with symmetric memory and wide halos. - real :: q(SZIBW_(CS),SZJBW_(CS)) ! A pseudo potential vorticity [T-1 Z-1 ~> s-1 m-1]. + real :: q(SZIBW_(CS),SZJBW_(CS)) ! A pseudo potential vorticity [T-1 Z-1 ~> s-1 m-1] + ! or [T-1 H-1 ~> s-1 m-1 or m2 s-1 kg-1] real, dimension(SZIBW_(CS),SZJW_(CS)) :: & ubt, & ! The zonal barotropic velocity [L T-1 ~> m s-1]. bt_rem_u, & ! The fraction of the barotropic zonal velocity that remains @@ -507,7 +519,7 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, Rayleigh_u, & ! A Rayleigh drag timescale operating at u-points [T-1 ~> s-1]. PFu_bt_sum, & ! The summed zonal barotropic pressure gradient force [L T-2 ~> m s-2]. Coru_bt_sum, & ! The summed zonal barotropic Coriolis acceleration [L T-2 ~> m s-2]. - DCor_u, & ! A simply averaged depth at u points [Z ~> m]. + DCor_u, & ! An averaged depth or total thickness at u points [Z ~> m] or [H ~> m or kg m-2]. Datu ! Basin depth at u-velocity grid points times the y-grid ! spacing [H L ~> m2 or kg m-1]. real, dimension(SZIW_(CS),SZJBW_(CS)) :: & @@ -538,7 +550,7 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, ! [L T-2 ~> m s-2]. Corv_bt_sum, & ! The summed meridional barotropic Coriolis acceleration, ! [L T-2 ~> m s-2]. - DCor_v, & ! A simply averaged depth at v points [Z ~> m]. + DCor_v, & ! An averaged depth or total thickness at v points [Z ~> m] or [H ~> m or kg m-2]. Datv ! Basin depth at v-velocity grid points times the x-grid ! spacing [H L ~> m2 or kg m-1]. real, target, dimension(SZIW_(CS),SZJW_(CS)) :: & @@ -606,6 +618,8 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, time_step_end, & ! The end time of a barotropic step. time_end_in ! The end time for diagnostics when this routine started. real :: time_int_in ! The diagnostics' time interval when this routine started. + real :: Htot_avg ! The average total thickness of the tracer columns adjacent to a + ! velocity point [H ~> m or kg m-2] logical :: do_hifreq_output ! If true, output occurs every barotropic step. logical :: use_BT_cont, do_ave, find_etaav, find_PF, find_Cor logical :: ice_is_rigid, nonblock_setup, interp_eta_PF @@ -624,6 +638,8 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, real :: Htot ! The total thickness [H ~> m or kg m-2]. real :: eta_cor_max ! The maximum fluid that can be added as a correction to eta [H ~> m or kg m-2]. real :: accel_underflow ! An acceleration that is so small it should be zeroed out [L T-2 ~> m s-2]. + real :: h_neglect ! A thickness that is so small it is usually lost + ! in roundoff and can be neglected [H ~> m or kg m-2]. real, allocatable, dimension(:) :: wt_vel, wt_eta, wt_accel, wt_trans, wt_accel2 real :: sum_wt_vel, sum_wt_eta, sum_wt_accel, sum_wt_trans @@ -651,6 +667,7 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB MS%isdw = CS%isdw ; MS%iedw = CS%iedw ; MS%jsdw = CS%jsdw ; MS%jedw = CS%jedw + h_neglect = GV%H_subroundoff Idt = 1.0 / dt accel_underflow = CS%vel_underflow * Idt @@ -815,23 +832,43 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, enddo ; enddo else q(:,:) = 0.0 ; DCor_u(:,:) = 0.0 ; DCor_v(:,:) = 0.0 - ! This option has not yet been written properly. - ! ### bathyT here should be replaced with bathyT+eta(Bous) or eta(non-Bous). - !$OMP parallel do default(shared) - do j=js,je ; do I=is-1,ie - DCor_u(I,j) = 0.5 * (G%bathyT(i+1,j) + G%bathyT(i,j)) - enddo ; enddo - !$OMP parallel do default(shared) - do J=js-1,je ; do i=is,ie - DCor_v(i,J) = 0.5 * (G%bathyT(i,j+1) + G%bathyT(i,j)) - enddo ; enddo - !$OMP parallel do default(shared) - do J=js-1,je ; do I=is-1,ie - q(I,J) = 0.25 * G%CoriolisBu(I,J) * & - ((G%areaT(i,j) + G%areaT(i+1,j+1)) + (G%areaT(i+1,j) + G%areaT(i,j+1))) / & - ((G%areaT(i,j) * G%bathyT(i,j) + G%areaT(i+1,j+1) * G%bathyT(i+1,j+1)) + & - (G%areaT(i+1,j) * G%bathyT(i+1,j) + G%areaT(i,j+1) * G%bathyT(i,j+1)) ) - enddo ; enddo + if (GV%Boussinesq) then + !$OMP parallel do default(shared) + do j=js,je ; do I=is-1,ie + DCor_u(I,j) = 0.5 * (max(GV%Z_to_H*G%bathyT(i+1,j) + eta_in(i+1,j), 0.0) + & + max(GV%Z_to_H*G%bathyT(i,j) + eta_in(i,j), 0.0) ) + enddo ; enddo + !$OMP parallel do default(shared) + do J=js-1,je ; do i=is,ie + DCor_v(i,J) = 0.5 * (max(GV%Z_to_H*G%bathyT(i,j+1) + eta_in(i+1,j), 0.0) + & + max(GV%Z_to_H*G%bathyT(i,j) + eta_in(i,j), 0.0) ) + enddo ; enddo + !$OMP parallel do default(shared) + do J=js-1,je ; do I=is-1,ie + q(I,J) = 0.25 * (CS%BT_Coriolis_scale * G%CoriolisBu(I,J)) * & + ((G%areaT(i,j) + G%areaT(i+1,j+1)) + (G%areaT(i+1,j) + G%areaT(i,j+1))) / & + (max((G%areaT(i,j) * max(GV%Z_to_H*G%bathyT(i,j) + eta_in(i,j), 0.0) + & + G%areaT(i+1,j+1) * max(GV%Z_to_H*G%bathyT(i+1,j+1) + eta_in(i+1,j+1), 0.0)) + & + (G%areaT(i+1,j) * max(GV%Z_to_H*G%bathyT(i+1,j) + eta_in(i+1,j), 0.0) + & + G%areaT(i,j+1) * max(GV%Z_to_H*G%bathyT(i,j+1) + eta_in(i,j+1), 0.0)), h_neglect) ) + enddo ; enddo + else + !$OMP parallel do default(shared) + do j=js,je ; do I=is-1,ie + DCor_u(I,j) = 0.5 * (eta_in(i+1,j) + eta_in(i,j)) + enddo ; enddo + !$OMP parallel do default(shared) + do J=js-1,je ; do i=is,ie + DCor_v(i,J) = 0.5 * (eta_in(i,j+1) + eta_in(i,j)) + enddo ; enddo + !$OMP parallel do default(shared) + do J=js-1,je ; do I=is-1,ie + q(I,J) = 0.25 * (CS%BT_Coriolis_scale * G%CoriolisBu(I,J)) * & + ((G%areaT(i,j) + G%areaT(i+1,j+1)) + (G%areaT(i+1,j) + G%areaT(i,j+1))) / & + (max((G%areaT(i,j) * eta_in(i,j) + G%areaT(i+1,j+1) * eta_in(i+1,j+1)) + & + (G%areaT(i+1,j) * eta_in(i+1,j) + G%areaT(i,j+1) * eta_in(i,j+1)), h_neglect) ) + enddo ; enddo + endif ! With very wide halos, q and D need to be calculated on the available data ! domain and then updated onto the full computational domain. @@ -976,50 +1013,6 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, Datu, Datv, BTCL_u, BTCL_v) endif -! Here the vertical average accelerations due to the Coriolis, advective, -! pressure gradient and horizontal viscous terms in the layer momentum -! equations are calculated. These will be used to determine the difference -! between the accelerations due to the average of the layer equations and the -! barotropic calculation. - - !$OMP parallel do default(shared) - do j=js,je ; do I=is-1,ie - ! ### IDatu here should be replaced with 1/D+eta(Bous) or 1/eta(non-Bous). - ! ### although with BT_cont_types IDatu should be replaced by - ! ### CS%dy_Cu(I,j) / (d(uhbt)/du) (with appropriate bounds). - BT_force_u(I,j) = forces%taux(I,j) * mass_accel_to_Z * CS%IDatu(I,j)*visc_rem_u(I,j,1) - enddo ; enddo - !$OMP parallel do default(shared) - do J=js-1,je ; do i=is,ie - ! ### IDatv here should be replaced with 1/D+eta(Bous) or 1/eta(non-Bous). - ! ### although with BT_cont_types IDatv should be replaced by - ! ### CS%dx_Cv(I,j) / (d(vhbt)/dv) (with appropriate bounds). - BT_force_v(i,J) = forces%tauy(i,J) * mass_accel_to_Z * CS%IDatv(i,J)*visc_rem_v(i,J,1) - enddo ; enddo - if (present(taux_bot) .and. present(tauy_bot)) then - if (associated(taux_bot) .and. associated(tauy_bot)) then - !$OMP parallel do default(shared) - do j=js,je ; do I=is-1,ie - BT_force_u(I,j) = BT_force_u(I,j) - taux_bot(I,j) * mass_to_Z * CS%IDatu(I,j) - enddo ; enddo - !$OMP parallel do default(shared) - do J=js-1,je ; do i=is,ie - BT_force_v(i,J) = BT_force_v(i,J) - tauy_bot(i,J) * mass_to_Z * CS%IDatv(i,J) - enddo ; enddo - endif - endif - - ! bc_accel_u & bc_accel_v are only available on the potentially - ! non-symmetric computational domain. - !$OMP parallel do default(shared) - do j=js,je ; do k=1,nz ; do I=Isq,Ieq - BT_force_u(I,j) = BT_force_u(I,j) + wt_u(I,j,k) * bc_accel_u(I,j,k) - enddo ; enddo ; enddo - !$OMP parallel do default(shared) - do J=Jsq,Jeq ; do k=1,nz ; do i=is,ie - BT_force_v(i,J) = BT_force_v(i,J) + wt_v(i,J,k) * bc_accel_v(i,J,k) - enddo ; enddo ; enddo - ! Determine the difference between the sum of the layer fluxes and the ! barotropic fluxes found from the same input velocities. if (add_uh0) then @@ -1128,6 +1121,82 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, ubt_first(:,:) = ubt(:,:) ; vbt_first(:,:) = vbt(:,:) endif +! Here the vertical average accelerations due to the Coriolis, advective, +! pressure gradient and horizontal viscous terms in the layer momentum +! equations are calculated. These will be used to determine the difference +! between the accelerations due to the average of the layer equations and the +! barotropic calculation. + + !$OMP parallel do default(shared) + do j=js,je ; do I=is-1,ie ; if (G%mask2dCu(I,j) > 0.0) then + if (CS%nonlin_stress) then + if (GV%Boussinesq) then + Htot_avg = 0.5*(max(CS%bathyT(i,j)*GV%Z_to_H + eta(i,j), 0.0) + & + max(CS%bathyT(i+1,j)*GV%Z_to_H + eta(i+1,j), 0.0)) + else + Htot_avg = 0.5*(eta(i,j) + eta(i+1,j)) + endif + if (Htot_avg*CS%dy_Cu(I,j) <= 0.0) then + CS%IDatu(I,j) = 0.0 + elseif (use_BT_cont) then ! Reconsider the max and whether there should be some scaling. + CS%IDatu(I,j) = CS%dy_Cu(I,j) / (max(find_duhbt_du(ubt(I,j), BTCL_u(I,j), US), & + CS%dy_Cu(I,j)*Htot_avg) ) + else + CS%IDatu(I,j) = 1.0 / Htot_avg + endif + endif + + BT_force_u(I,j) = forces%taux(I,j) * mass_accel_to_Z * CS%IDatu(I,j)*visc_rem_u(I,j,1) + else + BT_force_u(I,j) = 0.0 + endif ; enddo ; enddo + !$OMP parallel do default(shared) + do J=js-1,je ; do i=is,ie ; if (G%mask2dCv(i,J) > 0.0) then + if (CS%nonlin_stress) then + if (GV%Boussinesq) then + Htot_avg = 0.5*(max(CS%bathyT(i,j)*GV%Z_to_H + eta(i,j), 0.0) + & + max(CS%bathyT(i,j+1)*GV%Z_to_H + eta(i,j+1), 0.0)) + else + Htot_avg = 0.5*(eta(i,j) + eta(i,j+1)) + endif + if (Htot_avg*CS%dx_Cv(i,J) <= 0.0) then + CS%IDatv(i,J) = 0.0 + elseif (use_BT_cont) then ! Reconsider the max and whether there should be some scaling. + CS%IDatv(i,J) = CS%dx_Cv(i,J) / (max(find_dvhbt_dv(vbt(i,J), BTCL_v(i,J), US), & + CS%dx_Cv(i,J)*Htot_avg) ) + else + CS%IDatv(i,J) = 1.0 / Htot_avg + endif + endif + + BT_force_v(i,J) = forces%tauy(i,J) * mass_accel_to_Z * CS%IDatv(i,J)*visc_rem_v(i,J,1) + else + BT_force_v(i,J) = 0.0 + endif ; enddo ; enddo + if (present(taux_bot) .and. present(tauy_bot)) then + if (associated(taux_bot) .and. associated(tauy_bot)) then + !$OMP parallel do default(shared) + do j=js,je ; do I=is-1,ie ; if (G%mask2dCu(I,j) > 0.0) then + BT_force_u(I,j) = BT_force_u(I,j) - taux_bot(I,j) * mass_to_Z * CS%IDatu(I,j) + endif ; enddo ; enddo + !$OMP parallel do default(shared) + do J=js-1,je ; do i=is,ie ; if (G%mask2dCv(i,J) > 0.0) then + BT_force_v(i,J) = BT_force_v(i,J) - tauy_bot(i,J) * mass_to_Z * CS%IDatv(i,J) + endif ; enddo ; enddo + endif + endif + + ! bc_accel_u & bc_accel_v are only available on the potentially + ! non-symmetric computational domain. + !$OMP parallel do default(shared) + do j=js,je ; do k=1,nz ; do I=Isq,Ieq + BT_force_u(I,j) = BT_force_u(I,j) + wt_u(I,j,k) * bc_accel_u(I,j,k) + enddo ; enddo ; enddo + !$OMP parallel do default(shared) + do J=Jsq,Jeq ; do k=1,nz ; do i=is,ie + BT_force_v(i,J) = BT_force_v(i,J) + wt_v(i,J,k) * bc_accel_v(i,J,k) + enddo ; enddo ; enddo + if (CS%gradual_BT_ICs) then !$OMP parallel do default(shared) do j=js,je ; do I=is-1,ie @@ -1403,7 +1472,7 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, (gtot_N(i,j) * (Datv(i,J)*G%IdyCv(i,J)) + & gtot_S(i,j) * (Datv(i,J-1)*G%IdyCv(i,J-1)))) + & ((G%CoriolisBu(I,J)**2 + G%CoriolisBu(I-1,J-1)**2) + & - (G%CoriolisBu(I-1,J)**2 + G%CoriolisBu(I,J-1)**2))) + (G%CoriolisBu(I-1,J)**2 + G%CoriolisBu(I,J-1)**2)) * CS%BT_Coriolis_scale**2 ) H_eff_dx2 = max(H_min_dyn * ((G%IdxT(i,j))**2 + (G%IdyT(i,j))**2), & G%IareaT(i,j) * & ((Datu(I,j)*G%IdxCu(I,j) + Datu(I-1,j)*G%IdxCu(I-1,j)) + & @@ -1441,8 +1510,7 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, if (id_clock_calc_pre > 0) call cpu_clock_end(id_clock_calc_pre) if (id_clock_pass_pre > 0) call cpu_clock_begin(id_clock_pass_pre) - if (.not.use_BT_cont) & !### IS THIS OK HERE? - call complete_group_pass(CS%pass_Dat_uv, CS%BT_Domain) + if (.not.use_BT_cont) call complete_group_pass(CS%pass_Dat_uv, CS%BT_Domain) call complete_group_pass(CS%pass_force_hbt0_Cor_ref, CS%BT_Domain) call complete_group_pass(CS%pass_eta_bt_rem, CS%BT_Domain) @@ -1505,6 +1573,8 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, allocate(wt_accel2(nstep+nfilter+1)) do n=1,nstep+nfilter ! Modify this to use a different filter... + + ! This is a filter that ramps down linearly over a time dt_filt. if ( (n==nstep) .or. (dt_filt - abs(n-nstep)*dtbt >= 0.0)) then wt_vel(n) = 1.0 ; wt_eta(n) = 1.0 elseif (dtbt + dt_filt - abs(n-nstep)*dtbt > 0.0) then @@ -1512,8 +1582,9 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, else wt_vel(n) = 0.0 ; wt_eta(n) = 0.0 endif -!### if (n < nstep-nfilter) then ; wt_vel(n) = 0.0 ; else ; wt_vel(n) = 1.0 ; endif -!### if (n < nstep-nfilter) then ; wt_eta(n) = 0.0 ; else ; wt_eta(n) = 1.0 ; endif + ! This is a simple stepfunction filter. + ! if (n < nstep-nfilter) then ; wt_vel(n) = 0.0 ; else ; wt_vel(n) = 1.0 ; endif + ! wt_eta(n) = wt_vel(n) ! The rest should not be changed. sum_wt_vel = sum_wt_vel + wt_vel(n) ; sum_wt_eta = sum_wt_eta + wt_eta(n) @@ -1529,13 +1600,17 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, I_sum_wt_eta = 1.0 / sum_wt_eta ; I_sum_wt_trans = 1.0 / sum_wt_trans do n=1,nstep+nfilter wt_vel(n) = wt_vel(n) * I_sum_wt_vel - wt_accel2(n) = wt_accel(n) + if (CS%answers_2018) then + wt_accel2(n) = wt_accel(n) + ! wt_trans(n) = wt_trans(n) * I_sum_wt_trans + else + wt_accel2(n) = wt_accel(n) * I_sum_wt_accel + wt_trans(n) = wt_trans(n) * I_sum_wt_trans + endif wt_accel(n) = wt_accel(n) * I_sum_wt_accel wt_eta(n) = wt_eta(n) * I_sum_wt_eta -! wt_trans(n) = wt_trans(n) * I_sum_wt_trans enddo - sum_wt_vel = 0.0 ; sum_wt_eta = 0.0 ; sum_wt_accel = 0.0 ; sum_wt_trans = 0.0 ! The following loop contains all of the time steps. @@ -2003,7 +2078,6 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, eta(i,j) = (eta(i,j) + eta_src(i,j)) + (dtbt * CS%IareaT(i,j)) * & ((uhbt(I-1,j) - uhbt(I,j)) + (vhbt(i,J-1) - vhbt(i,J))) eta_wtd(i,j) = eta_wtd(i,j) + eta(i,j) * wt_eta(n) - ! Should there be a concern if eta drops below 0 or G%bathyT? enddo ; enddo if (do_hifreq_output) then @@ -2024,6 +2098,18 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, call hchksum(eta, trim(mesg)//" eta", CS%debug_BT_HI, haloshift=iev-ie, scale=GV%H_to_m) endif + if (GV%Boussinesq) then + do j=js,je ; do i=is,ie + if (eta(i,j) < -GV%Z_to_H*G%bathyT(i,j)) & + call MOM_error(WARNING, "btstep: eta has dropped below bathyT.") + enddo ; enddo + else + do j=js,je ; do i=is,ie + if (eta(i,j) < 0.0) & + call MOM_error(WARNING, "btstep: negative eta in a non-Boussinesq barotropic solver.") + enddo ; enddo + endif + enddo ! end of do n=1,ntimestep if (id_clock_calc > 0) call cpu_clock_end(id_clock_calc) if (id_clock_calc_post > 0) call cpu_clock_begin(id_clock_calc_post) @@ -2031,8 +2117,12 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, ! Reset the time information in the diag type. if (do_hifreq_output) call enable_averaging(time_int_in, time_end_in, CS%diag) - I_sum_wt_vel = 1.0 / sum_wt_vel ; I_sum_wt_eta = 1.0 / sum_wt_eta - I_sum_wt_accel = 1.0 / sum_wt_accel ; I_sum_wt_trans = 1.0 / sum_wt_trans + if (CS%answers_2018) then + I_sum_wt_vel = 1.0 / sum_wt_vel ; I_sum_wt_eta = 1.0 / sum_wt_eta + I_sum_wt_accel = 1.0 / sum_wt_accel ; I_sum_wt_trans = 1.0 / sum_wt_trans + else + I_sum_wt_vel = 1.0 ; I_sum_wt_eta = 1.0 ; I_sum_wt_accel = 1.0 ; I_sum_wt_trans = 1.0 + endif if (find_etaav) then ; do j=js,je ; do i=is,ie etaav(i,j) = eta_sum(i,j) * I_sum_wt_accel @@ -2089,21 +2179,30 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, if (id_clock_pass_post > 0) call cpu_clock_end(id_clock_pass_post) if (id_clock_calc_post > 0) call cpu_clock_begin(id_clock_calc_post) - do j=js,je ; do I=is-1,ie - CS%ubtav(I,j) = ubt_sum(I,j) * I_sum_wt_trans - uhbtav(I,j) = uhbt_sum(I,j) * I_sum_wt_trans - ! The following line would do approximately nothing, as I_sum_wt_accel ~= 1. - !### u_accel_bt(I,j) = u_accel_bt(I,j) * I_sum_wt_accel - ubt_wtd(I,j) = ubt_wtd(I,j) * I_sum_wt_vel - enddo ; enddo + if (CS%answers_2018) then + do j=js,je ; do I=is-1,ie + CS%ubtav(I,j) = ubt_sum(I,j) * I_sum_wt_trans + uhbtav(I,j) = uhbt_sum(I,j) * I_sum_wt_trans + ubt_wtd(I,j) = ubt_wtd(I,j) * I_sum_wt_vel + enddo ; enddo + + do J=js-1,je ; do i=is,ie + CS%vbtav(i,J) = vbt_sum(i,J) * I_sum_wt_trans + vhbtav(i,J) = vhbt_sum(i,J) * I_sum_wt_trans + vbt_wtd(i,J) = vbt_wtd(i,J) * I_sum_wt_vel + enddo ; enddo + else + do j=js,je ; do I=is-1,ie + CS%ubtav(I,j) = ubt_sum(I,j) + uhbtav(I,j) = uhbt_sum(I,j) + enddo ; enddo + + do J=js-1,je ; do i=is,ie + CS%vbtav(i,J) = vbt_sum(i,J) + vhbtav(i,J) = vhbt_sum(i,J) + enddo ; enddo + endif - do J=js-1,je ; do i=is,ie - CS%vbtav(i,J) = vbt_sum(i,J) * I_sum_wt_trans - vhbtav(i,J) = vhbt_sum(i,J) * I_sum_wt_trans - ! The following line would do approximately nothing, as I_sum_wt_accel ~= 1. - !### v_accel_bt(i,J) = v_accel_bt(i,J) * I_sum_wt_accel - vbt_wtd(i,J) = vbt_wtd(i,J) * I_sum_wt_vel - enddo ; enddo if (id_clock_calc_post > 0) call cpu_clock_end(id_clock_calc_post) if (id_clock_pass_post > 0) call cpu_clock_begin(id_clock_pass_post) @@ -2359,7 +2458,7 @@ subroutine set_dtbt(G, GV, US, CS, eta, pbce, BT_cont, gtot_est, SSH_add) ((gtot_E(i,j)*Datu(I,j)*G%IdxCu(I,j) + gtot_W(i,j)*Datu(I-1,j)*G%IdxCu(I-1,j)) + & (gtot_N(i,j)*Datv(i,J)*G%IdyCv(i,J) + gtot_S(i,j)*Datv(i,J-1)*G%IdyCv(i,J-1))) + & ((G%CoriolisBu(I,J)**2 + G%CoriolisBu(I-1,J-1)**2) + & - (G%CoriolisBu(I-1,J)**2 + G%CoriolisBu(I,J-1)**2))) + (G%CoriolisBu(I-1,J)**2 + G%CoriolisBu(I,J-1)**2)) * CS%BT_Coriolis_scale**2 ) if (Idt_max2 * min_max_dt2 > 1.0) min_max_dt2 = 1.0 / Idt_max2 enddo ; enddo dtbt_max = sqrt(min_max_dt2 / dgeo_de) @@ -3050,6 +3149,31 @@ function find_uhbt(u, BTC, US) result(uhbt) end function find_uhbt +!> The function find_duhbt_du determines the marginal zonal face area for a given velocity. +function find_duhbt_du(u, BTC, US) result(duhbt_du) + real, intent(in) :: u !< The local zonal velocity [L T-1 ~> m s-1] + 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. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + + real :: duhbt_du !< The zonal barotropic face area [L H ~> m2] + + if (u == 0.0) then + duhbt_du = 0.5*(BTC%FA_u_E0 + BTC%FA_u_W0) ! Note the potential discontinuity here. + elseif (u < BTC%uBT_EE) then + duhbt_du = BTC%FA_u_EE + elseif (u < 0.0) then + duhbt_du = (BTC%FA_u_E0 + 3.0*BTC%uh_crvE * u**2) + elseif (u <= BTC%uBT_WW) then + duhbt_du = (BTC%FA_u_W0 + 3.0*BTC%uh_crvW * u**2) + else ! (u > BTC%uBT_WW) + duhbt_du = BTC%FA_u_WW + endif + +end function find_duhbt_du + + !> This function inverts the transport function to determine the barotopic !! velocity that is consistent with a given transport. function uhbt_to_ubt(uhbt, BTC, US, guess) result(ubt) @@ -3167,6 +3291,29 @@ function find_vhbt(v, BTC, US) result(vhbt) end function find_vhbt +!> The function find_vhbt determines the meridional transport for a given velocity. +function find_dvhbt_dv(v, BTC, US) result(dvhbt_dv) + real, intent(in) :: v !< The local meridional velocity [L T-1 ~> m s-1] + 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. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real :: dvhbt_dv !< The meridional barotropic face area [L H ~> m2] + + if (v == 0.0) then + dvhbt_dv = 0.5*(BTC%FA_v_N0 + BTC%FA_v_S0) ! Note the potential discontinuity here. + elseif (v < BTC%vBT_NN) then + dvhbt_dv = BTC%FA_v_NN + elseif (v < 0.0) then + dvhbt_dv = BTC%FA_v_N0 + 3.0*BTC%vh_crvN * v**2 + elseif (v <= BTC%vBT_SS) then + dvhbt_dv = BTC%FA_v_S0 + 3.0*BTC%vh_crvS * v**2 + else ! (v > BTC%vBT_SS) + dvhbt_dv = BTC%FA_v_SS + endif + +end function find_dvhbt_dv + !> This function inverts the transport function to determine the barotopic !! velocity that is consistent with a given transport. function vhbt_to_vbt(vhbt, BTC, US, guess) result(vbt) @@ -3756,6 +3903,7 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, type(memory_size_type) :: MS type(group_pass_type) :: pass_static_data, pass_q_D_Cor type(group_pass_type) :: pass_bt_hbt_btav, pass_a_polarity + logical :: default_2018_answers ! The default setting for the various 2018_ANSWERS flags. logical :: apply_bt_drag, use_BT_cont_type character(len=48) :: thickness_units, flux_units character*(40) :: hvel_str @@ -3862,6 +4010,10 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, "to do a corrector continuity step using a weighted "//& "average of the old and new velocities, with weights "//& "of (1-BEBT) and BEBT.", default=.false.) + call get_param(param_file, mdl, "BT_NONLIN_STRESS", CS%nonlin_stress, & + "If true, use the full depth of the ocean at the start of the barotropic "//& + "step when calculating the surface stress contribution to the barotropic "//& + "acclerations. Otherwise use the depth based on bathyT.", default=.false.) call get_param(param_file, mdl, "DYNAMIC_SURFACE_PRESSURE", CS%dynamic_psurf, & "If true, add a dynamic pressure due to a viscous ice "//& @@ -3882,6 +4034,16 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, "if DYNAMIC_SURFACE_PRESSURE is true. Stable values "//& "are < ~1.0.", units="nondim", default=0.9) endif + call get_param(param_file, mdl, "BT_CORIOLIS_SCALE", CS%BT_Coriolis_scale, & + "A factor by which the barotropic Coriolis anomaly terms are scaled.", & + units="nondim", default=1.0) + call get_param(param_file, "MOM", "DEFAULT_2018_ANSWERS", default_2018_answers, & + "This sets the default value for the various _2018_ANSWERS parameters.", & + default=.true.) + call get_param(param_file, "MOM", "BAROTROPIC_2018_ANSWERS", CS%answers_2018, & + "If true, use expressions for the barotropic solver that recover the answers "//& + "from the end of 2018. Otherwise, use more efficient or general expressions.", & + default=default_2018_answers) call get_param(param_file, mdl, "TIDES", CS%tides, & "If true, apply tidal momentum forcing.", default=.false.) @@ -3990,7 +4152,9 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, "quite large if this is true.", default=CS%debug, & debuggingParam=.true.) - CS%linearized_BT_PV = .true. + call get_param(param_file, mdl, "LINEARIZED_BT_CORIOLIS", CS%linearized_BT_PV, & + "If true use the bottom depth instead of the total water column thickness "//& + "in the barotropic Coriolis term calculations.", default=.true.) call get_param(param_file, mdl, "BEBT", CS%bebt, & "BEBT determines whether the barotropic time stepping "//& "uses the forward-backward time-stepping scheme or a "//& @@ -4013,6 +4177,9 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, "If True, use an order of operations that is not bitwise "//& "rotationally symmetric in the meridional Coriolis term of "//& "the barotropic solver.", default=.false.) + call get_param(param_file, mdl, "MEAN_SEALEV", CS%Mean_SL, & + "A mean sea level that is added to bathyT when LINEARIZED_BT_PV is true.", & + units="m", default=0.0, scale=US%m_to_Z, do_not_log=.not.CS%linearized_BT_PV) ! Initialize a version of the MOM domain that is specific to the barotropic solver. call clone_MOM_domain(G%Domain, CS%BT_Domain, min_halo=wd_halos, symmetric=.true.) @@ -4106,18 +4273,21 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, ALLOC_(CS%D_u_Cor(CS%isdw-1:CS%iedw,CS%jsdw:CS%jedw)) ALLOC_(CS%D_v_Cor(CS%isdw:CS%iedw,CS%jsdw-1:CS%jedw)) CS%q_D(:,:) = 0.0 ; CS%D_u_Cor(:,:) = 0.0 ; CS%D_v_Cor(:,:) = 0.0 + do j=js,je ; do I=is-1,ie - CS%D_u_Cor(I,j) = 0.5 * (G%bathyT(i+1,j) + G%bathyT(i,j)) + CS%D_u_Cor(I,j) = 0.5 * (max(CS%Mean_SL+G%bathyT(i+1,j),0.0) + max(CS%Mean_SL+G%bathyT(i,j),0.0)) enddo ; enddo do J=js-1,je ; do i=is,ie - CS%D_v_Cor(i,J) = 0.5 * (G%bathyT(i,j+1) + G%bathyT(i,j)) + CS%D_v_Cor(i,J) = 0.5 * (max(CS%Mean_SL+G%bathyT(i,j+1),0.0) + max(CS%Mean_SL+G%bathyT(i,j),0.0)) enddo ; enddo do J=js-1,je ; do I=is-1,ie if (G%mask2dT(i,j)+G%mask2dT(i,j+1)+G%mask2dT(i+1,j)+G%mask2dT(i+1,j+1)>0.) then - CS%q_D(I,J) = 0.25 * G%CoriolisBu(I,J) * & + CS%q_D(I,J) = 0.25 * (CS%BT_Coriolis_scale * G%CoriolisBu(I,J)) * & ((G%areaT(i,j) + G%areaT(i+1,j+1)) + (G%areaT(i+1,j) + G%areaT(i,j+1))) / & - ((G%areaT(i,j) * G%bathyT(i,j) + G%areaT(i+1,j+1) * G%bathyT(i+1,j+1)) + & - (G%areaT(i+1,j) * G%bathyT(i+1,j) + G%areaT(i,j+1) * G%bathyT(i,j+1)) ) + (max(((G%areaT(i,j) * max(CS%Mean_SL+G%bathyT(i,j),0.0) + & + G%areaT(i+1,j+1) * max(CS%Mean_SL+G%bathyT(i+1,j+1),0.0)) + & + (G%areaT(i+1,j) * max(CS%Mean_SL+G%bathyT(i+1,j),0.0) + & + G%areaT(i,j+1) * max(CS%Mean_SL+G%bathyT(i,j+1),0.0))), GV%H_to_Z*GV%H_subroundoff) ) else ! All four h points are masked out so q_D(I,J) will is meaningless CS%q_D(I,J) = 0. endif @@ -4331,25 +4501,25 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, do j=js,je ; do I=is-1,ie if (G%mask2dCu(I,j)>0.) then - CS%IDatu(I,j) = G%mask2dCu(I,j) * 2.0 / (G%bathyT(i+1,j) + G%bathyT(i,j)) + CS%IDatu(I,j) = G%mask2dCu(I,j) * 2.0 / ((G%bathyT(i+1,j) + G%bathyT(i,j)) + 2.0*CS%Mean_SL) else ! Both neighboring H points are masked out so IDatu(I,j) is meaningless CS%IDatu(I,j) = 0. endif enddo ; enddo do J=js-1,je ; do i=is,ie if (G%mask2dCv(i,J)>0.) then - CS%IDatv(i,J) = G%mask2dCv(i,J) * 2.0 / (G%bathyT(i,j+1) + G%bathyT(i,j)) + CS%IDatv(i,J) = G%mask2dCv(i,J) * 2.0 / ((G%bathyT(i,j+1) + G%bathyT(i,j)) + 2.0*CS%Mean_SL) else ! Both neighboring H points are masked out so IDatv(I,j) is meaningless CS%IDatv(i,J) = 0. endif enddo ; enddo call find_face_areas(Datu, Datv, G, GV, US, CS, MS, halo=1) - if (CS%bound_BT_corr) then - ! ### Consider replacing maxvel with G%dxT(i,j) * (CS%maxCFL_BT_cont*Idt) - ! ### and G%dyT(i,j) * (CS%maxCFL_BT_cont*Idt) + if ((CS%bound_BT_corr) .and. .not.(use_BT_Cont_type .and. CS%BT_cont_bounds)) then + ! This is not used in most test cases. Were it ever to become more widely used, consider + ! replacing maxvel with min(G%dxT(i,j),G%dyT(i,j)) * (CS%maxCFL_BT_cont*Idt) . do j=js,je ; do i=is,ie - CS%eta_cor_bound(i,j) = GV%m_to_H * G%IareaT(i,j) * 0.1 * CS%maxvel * & + CS%eta_cor_bound(i,j) = G%IareaT(i,j) * 0.1 * CS%maxvel * & ((Datu(I-1,j) + Datu(I,j)) + (Datv(i,J) + Datv(i,J-1))) enddo ; enddo endif From a6c4261b40fc81ba7b8369b570d4b5a15e9e315e Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sat, 8 Feb 2020 20:06:51 -0500 Subject: [PATCH 055/316] +Add dimensional rescaling to Idealized_Hurricane Added dimensional consistency testing to Idealized_Hurricane and added the new runtime parameter IDL_HURR_2018_ANSWERS surrounding some answer-changing modifications. By default all answers are bitwise identical, but there is a new entry in a few MOM_parameter_doc files. --- src/user/Idealized_Hurricane.F90 | 467 +++++++++++++++++-------------- 1 file changed, 260 insertions(+), 207 deletions(-) diff --git a/src/user/Idealized_Hurricane.F90 b/src/user/Idealized_Hurricane.F90 index b4cbb32401..61765b2586 100644 --- a/src/user/Idealized_Hurricane.F90 +++ b/src/user/Idealized_Hurricane.F90 @@ -45,28 +45,30 @@ module Idealized_hurricane type, public :: idealized_hurricane_CS ; private ! Parameters used to compute Holland radial wind profile - real :: rho_a !< Mean air density [kg m-3] - real :: pressure_ambient !< Pressure at surface of ambient air [Pa] - real :: pressure_central !< Pressure at surface at hurricane center [Pa] - real :: rad_max_wind !< Radius of maximum winds [m] - real :: max_windspeed !< Maximum wind speeds [m s-1] - real :: hurr_translation_spd !< Hurricane translation speed [m s-1] - real :: hurr_translation_dir !< Hurricane translation speed [m s-1] - real :: gustiness !< Gustiness (optional, used in u*) [R L Z T-1 ~> Pa] + real :: rho_a !< Mean air density [R ~> kg m-3] + real :: pressure_ambient !< Pressure at surface of ambient air [R L2 T-2 ~> Pa] + real :: pressure_central !< Pressure at surface at hurricane center [R L2 T-2 ~> Pa] + real :: rad_max_wind !< Radius of maximum winds [L ~> m] + real :: max_windspeed !< Maximum wind speeds [L T-1 ~> m s-1] + real :: hurr_translation_spd !< Hurricane translation speed [L T-1 ~> m s-1] + real :: hurr_translation_dir !< Hurricane translation direction [radians] + real :: gustiness !< Gustiness (optional, used in u*) [R L Z T-2 ~> Pa] real :: Rho0 !< A reference ocean density [R ~> kg m-3] real :: Hurr_cen_Y0 !< The initial y position of the hurricane !! This experiment is conducted in a Cartesian - !! grid and this is assumed to be in meters [m] + !! grid and this is assumed to be in meters [L ~> m] real :: Hurr_cen_X0 !< The initial x position of the hurricane !! This experiment is conducted in a Cartesian - !! grid and this is assumed to be in meters [m] - real :: Holland_A !< Parameter 'A' from the Holland formula - real :: Holland_B !< Parameter 'B' from the Holland formula + !! grid and this is assumed to be in meters [L ~> m] + real :: Holland_A !< Parameter 'A' from the Holland formula [nondim] + real :: Holland_B !< Parameter 'B' from the Holland formula [nondim] real :: Holland_AxBxDP !< 'A' x 'B' x (Pressure Ambient-Pressure central) - !! for the Holland prorfile calculation + !! for the Holland prorfile calculation [R L2 T-2 ~> Pa] logical :: relative_tau !< A logical to take difference between wind - !! and surface currents to compute the stress - + !! and surface currents to compute the stress + logical :: answers_2018 !< If true, use expressions driving the idealized hurricane test + !! case that recover the answers from the end of 2018. Otherwise use + !! expressions that are rescalable and respect rotational symmetry. ! Parameters used if in SCM (single column model) mode logical :: SCM_mode !< If true this being used in Single Column Model mode @@ -74,7 +76,7 @@ module Idealized_hurricane !! provide identical wind to reproduce a previous !! experiment, where that wind formula contained !! an error) - real :: DY_from_center !< (Fixed) distance in y from storm center path [m] + real :: dy_from_center !< (Fixed) distance in y from storm center path [L ~> m] ! Par real :: PI !< Mathematical constant @@ -97,10 +99,13 @@ subroutine idealized_hurricane_wind_init(Time, G, US, param_file, CS) type(param_file_type), intent(in) :: param_file !< Input parameter structure type(idealized_hurricane_CS), pointer :: CS !< Parameter container for this module - real :: DP, C + ! Local variables + real :: dP ! The pressure difference across the hurricane [R L2 T-2 ~> Pa] + real :: C + logical :: default_2018_answers ! The default setting for the various 2018_ANSWERS flags. -! This include declares and sets the variable "version". -#include "version_variable.h" + ! This include declares and sets the variable "version". +# include "version_variable.h" if (associated(CS)) then call MOM_error(FATAL, "idealized_hurricane_wind_init called "// & @@ -118,37 +123,34 @@ subroutine idealized_hurricane_wind_init(Time, G, US, param_file, CS) ! Parameters for computing a wind profile call get_param(param_file, mdl, "IDL_HURR_RHO_AIR", CS%rho_a, & - "Air density used to compute the idealized hurricane "//& - "wind profile.", units='kg/m3', default=1.2) - call get_param(param_file, mdl, "IDL_HURR_AMBIENT_PRESSURE", & - CS%pressure_ambient, "Ambient pressure used in the "//& - "idealized hurricane wind profile.", units='Pa', & - default=101200.) - call get_param(param_file, mdl, "IDL_HURR_CENTRAL_PRESSURE", & - CS%pressure_central, "Central pressure used in the "//& - "idealized hurricane wind profile.", units='Pa', & - default=96800.) + "Air density used to compute the idealized hurricane wind profile.", & + units='kg/m3', default=1.2, scale=US%kg_m3_to_R) + call get_param(param_file, mdl, "IDL_HURR_AMBIENT_PRESSURE", CS%pressure_ambient, & + "Ambient pressure used in the idealized hurricane wind profile.", & + units='Pa', default=101200., scale=US%m_s_to_L_T**2*US%kg_m3_to_R) + call get_param(param_file, mdl, "IDL_HURR_CENTRAL_PRESSURE", CS%pressure_central, & + "Central pressure used in the idealized hurricane wind profile.", & + units='Pa', default=96800., scale=US%m_s_to_L_T**2*US%kg_m3_to_R) call get_param(param_file, mdl, "IDL_HURR_RAD_MAX_WIND", & CS%rad_max_wind, "Radius of maximum winds used in the "//& "idealized hurricane wind profile.", units='m', & - default=50.e3) + default=50.e3, scale=US%m_to_L) call get_param(param_file, mdl, "IDL_HURR_MAX_WIND", CS%max_windspeed, & "Maximum wind speed used in the idealized hurricane"// & - "wind profile.", units='m/s', default=65.) + "wind profile.", units='m/s', default=65., scale=US%m_s_to_L_T) call get_param(param_file, mdl, "IDL_HURR_TRAN_SPEED", CS%hurr_translation_spd, & "Translation speed of hurricane used in the idealized "//& - "hurricane wind profile.", units='m/s', default=5.0) + "hurricane wind profile.", units='m/s', default=5.0, scale=US%m_s_to_L_T) call get_param(param_file, mdl, "IDL_HURR_TRAN_DIR", CS%hurr_translation_dir, & "Translation direction (towards) of hurricane used in the "//& "idealized hurricane wind profile.", units='degrees', & - default=180.0) - CS%hurr_translation_dir = CS%hurr_translation_dir * CS%Deg2Rad + default=180.0, scale=CS%Deg2Rad) call get_param(param_file, mdl, "IDL_HURR_X0", CS%Hurr_cen_X0, & "Idealized Hurricane initial X position", & - units='m', default=0.) + units='m', default=0., scale=US%m_to_L) call get_param(param_file, mdl, "IDL_HURR_Y0", CS%Hurr_cen_Y0, & "Idealized Hurricane initial Y position", & - units='m', default=0.) + units='m', default=0., scale=US%m_to_L) call get_param(param_file, mdl, "IDL_HURR_TAU_CURR_REL", CS%relative_tau, & "Current relative stress switch "//& "used in the idealized hurricane wind profile.", & @@ -163,9 +165,16 @@ subroutine idealized_hurricane_wind_init(Time, G, US, param_file, CS) "Single Column mode switch "//& "used in the SCM idealized hurricane wind profile.", & units='', default=.false.) - call get_param(param_file, mdl, "IDL_HURR_SCM_LOCY", CS%DY_from_center, & + call get_param(param_file, mdl, "IDL_HURR_SCM_LOCY", CS%dy_from_center, & "Y distance of station used in the SCM idealized hurricane "//& - "wind profile.", units='m', default=50.e3) + "wind profile.", units='m', default=50.e3, scale=US%m_to_L) + call get_param(param_file, mdl, "DEFAULT_2018_ANSWERS", default_2018_answers, & + "This sets the default value for the various _2018_ANSWERS parameters.", & + default=.true.) + call get_param(param_file, mdl, "IDL_HURR_2018_ANSWERS", CS%answers_2018, & + "If true, use expressions driving the idealized hurricane test case that recover "//& + "the answers from the end of 2018. Otherwise use expressions that are rescalable "//& + "and respect rotational symmetry.", default=default_2018_answers) ! The following parameters are model run-time parameters which are used ! and logged elsewhere and so should not be logged here. The default @@ -182,13 +191,17 @@ subroutine idealized_hurricane_wind_init(Time, G, US, param_file, CS) if (CS%BR_BENCH) then - CS%rho_a = 1.2 + CS%rho_a = 1.2*US%kg_m3_to_R endif - DP = CS%pressure_ambient - CS%pressure_central - C = CS%max_windspeed / sqrt( DP ) - CS%Holland_B = C**2 * CS%rho_a * exp(1.0) - CS%Holland_A = (CS%rad_max_wind)**CS%Holland_B - CS%Holland_AxBxDP = CS%Holland_A*CS%Holland_B*DP + dP = CS%pressure_ambient - CS%pressure_central + if (CS%answers_2018) then + C = CS%max_windspeed / sqrt( US%R_to_kg_m3 * dP ) + CS%Holland_B = C**2 * US%R_to_kg_m3*CS%rho_a * exp(1.0) + else + CS%Holland_B = CS%max_windspeed**2 * CS%rho_a * exp(1.0) / dP + endif + CS%Holland_A = (US%L_to_m*CS%rad_max_wind)**CS%Holland_B + CS%Holland_AxBxDP = CS%Holland_A*CS%Holland_B*dP end subroutine idealized_hurricane_wind_init @@ -205,17 +218,16 @@ subroutine idealized_hurricane_wind_forcing(state, forces, day, G, US, CS) integer :: i, j, is, ie, js, je, Isq, Ieq, Jsq, Jeq integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB - real :: TX,TY !< wind stress - real :: Uocn, Vocn !< Surface ocean velocity components - real :: LAT, LON !< Grid location - real :: YY, XX !< storm relative position - real :: XC, YC !< Storm center location - real :: f !< Coriolis - real :: fbench !< The benchmark 'f' value + real :: TX, TY !< wind stress components [R L Z T-2 ~> Pa] + real :: Uocn, Vocn !< Surface ocean velocity components [L T-1 ~> m s-1] + real :: YY, XX !< storm relative position [L ~> m] + real :: XC, YC !< Storm center location [L ~> m] + real :: f_local !< Local Coriolis parameter [T-1 ~> s-1] + real :: fbench !< The benchmark 'f' value [T-1 ~> s-1] real :: fbench_fac !< A factor that is set to 0 to use the - !! benchmark 'f' value + !! benchmark 'f' value [nondim] real :: rel_tau_fac !< A factor that is set to 0 to disable - !! current relative stress calculation + !! current relative stress calculation [nondim] ! Bounds for loops and memory allocation is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec @@ -233,61 +245,67 @@ subroutine idealized_hurricane_wind_forcing(state, forces, day, G, US, CS) endif !> Compute storm center location - XC = CS%Hurr_cen_X0 + (time_type_to_real(day)*CS%hurr_translation_spd*& + XC = CS%Hurr_cen_X0 + (time_type_to_real(day)*US%s_to_T * CS%hurr_translation_spd * & cos(CS%hurr_translation_dir)) - YC = CS%Hurr_cen_Y0 + (time_type_to_real(day)*CS%hurr_translation_spd*& + YC = CS%Hurr_cen_Y0 + (time_type_to_real(day)*US%s_to_T * CS%hurr_translation_spd * & sin(CS%hurr_translation_dir)) if (CS%BR_Bench) then - ! f reset to value used in generated wind for benchmark test - fbench = 5.5659e-05 - fbench_fac = 0.0 + ! f reset to value used in generated wind for benchmark test + fbench = 5.5659e-05 * US%T_to_s + fbench_fac = 0.0 else - fbench = 0.0 - fbench_fac = 1.0 + fbench = 0.0 + fbench_fac = 1.0 endif !> Computes taux do j=js,je do I=is-1,Ieq - Uocn = state%u(I,j)*REL_TAU_FAC - Vocn = 0.25*(state%v(i,J)+state%v(i+1,J-1)& - +state%v(i+1,J)+state%v(i,J-1))*REL_TAU_FAC - f = abs(0.5*US%s_to_T*(G%CoriolisBu(I,J)+G%CoriolisBu(I,J-1)))*fbench_fac + fbench + Uocn = US%m_s_to_L_T * state%u(I,j)*REL_TAU_FAC + if (CS%answers_2018) then + Vocn = US%m_s_to_L_T * 0.25*(state%v(i,J)+state%v(i+1,J-1)& + +state%v(i+1,J)+state%v(i,J-1))*REL_TAU_FAC + else + Vocn = US%m_s_to_L_T * 0.25*((state%v(i,J)+state%v(i+1,J-1)) +& + (state%v(i+1,J)+state%v(i,J-1))) * REL_TAU_FAC + endif + f_local = abs(0.5*(G%CoriolisBu(I,J)+G%CoriolisBu(I,J-1)))*fbench_fac + fbench ! Calculate position as a function of time. if (CS%SCM_mode) then YY = YC + CS%dy_from_center XX = XC else - LAT = G%geoLatCu(I,j)*1000. ! Convert Lat from km to m. - LON = G%geoLonCu(I,j)*1000. ! Convert Lon from km to m. - YY = LAT - YC - XX = LON - XC + YY = G%geoLatCu(I,j)*1000.*US%m_to_L - YC + XX = G%geoLonCu(I,j)*1000.*US%m_to_L - XC endif - call idealized_hurricane_wind_profile(CS,f,YY,XX,Uocn,Vocn,TX,TY) - forces%taux(I,j) = G%mask2dCu(I,j) * US%kg_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z * TX + call idealized_hurricane_wind_profile(CS, US, f_local, YY, XX, Uocn, Vocn, TX, TY) + forces%taux(I,j) = G%mask2dCu(I,j) * TX enddo enddo !> Computes tauy do J=js-1,Jeq do i=is,ie - Uocn = 0.25*(state%u(I,j)+state%u(I-1,j+1)& - +state%u(I-1,j)+state%u(I,j+1))*REL_TAU_FAC - Vocn = state%v(i,J)*REL_TAU_FAC - f = abs(0.5*US%s_to_T*(G%CoriolisBu(I-1,J)+G%CoriolisBu(I,J)))*fbench_fac + fbench + if (CS%answers_2018) then + Uocn = US%m_s_to_L_T * 0.25*(state%u(I,j)+state%u(I-1,j+1) + & + state%u(I-1,j)+state%u(I,j+1))*REL_TAU_FAC + else + Uocn = US%m_s_to_L_T * 0.25*((state%u(I,j)+state%u(I-1,j+1)) + & + (state%u(I-1,j)+state%u(I,j+1))) * REL_TAU_FAC + endif + Vocn = US%m_s_to_L_T * state%v(i,J)*REL_TAU_FAC + f_local = abs(0.5*(G%CoriolisBu(I-1,J)+G%CoriolisBu(I,J)))*fbench_fac + fbench ! Calculate position as a function of time. if (CS%SCM_mode) then YY = YC + CS%dy_from_center XX = XC else - LAT = G%geoLatCv(i,J)*1000. ! Convert Lat from km to m. - LON = G%geoLonCv(i,J)*1000. ! Convert Lon from km to m. - YY = LAT - YC - XX = LON - XC + YY = G%geoLatCv(i,J)*1000.*US%m_to_L - YC + XX = G%geoLonCv(i,J)*1000.*US%m_to_L - XC endif - call idealized_hurricane_wind_profile(CS, f, YY, XX, Uocn, Vocn, TX, TY) - forces%tauy(i,J) = G%mask2dCv(i,J) * US%kg_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z * TY + call idealized_hurricane_wind_profile(CS, US, f_local, YY, XX, Uocn, Vocn, TX, TY) + forces%tauy(i,J) = G%mask2dCv(i,J) * TY enddo enddo @@ -305,34 +323,34 @@ subroutine idealized_hurricane_wind_forcing(state, forces, day, G, US, CS) end subroutine idealized_hurricane_wind_forcing !> Calculate the wind speed at a location as a function of time. -subroutine idealized_hurricane_wind_profile(CS, absf, YY, XX, UOCN, VOCN, Tx, Ty) +subroutine idealized_hurricane_wind_profile(CS, US, absf, YY, XX, UOCN, VOCN, Tx, Ty) ! Author: Brandon Reichl ! Date: Nov-20-2014 ! Aug-14-2018 Generalized for non-SCM configuration ! Input parameters - type(idealized_hurricane_CS), & - pointer :: CS !< Container for SCM parameters - real, intent(in) :: absf ! s-1] + real, intent(in) :: YY !< Location in m relative to center y [L ~> m] + real, intent(in) :: XX !< Location in m relative to center x [L ~> m] + real, intent(in) :: UOCN !< X surface current [L T-1 ~> m s-1] + real, intent(in) :: VOCN !< Y surface current [L T-1 ~> m s-1] + real, intent(out) :: Tx !< X stress [R L Z T-2 ~> Pa] + real, intent(out) :: Ty !< Y stress [R L Z T-2 ~> Pa] ! Local variables ! Wind profile terms - real :: U10 - real :: radius - real :: radius10 - real :: radius_km + real :: U10 ! The 10 m wind speed [L T-1 ~> m s-1] + real :: radius ! The distance from the hurricane center [L ~> m] + real :: radius10 ! 10 times the distance from the hurricane center [L ~> m] + real :: radius_km ! The distance from the hurricane center, perhaps in km [L ~> m] or [1000 L ~> km] real :: radiusB - real :: fcor - real :: du10 - real :: du - real :: dv + real :: tmp ! A temporary variable [R L T-1 ~> kg m-2 s-1] + real :: du10 ! The magnitude of the difference between the 10 m wind and the ocean flow [L T-1 ~> m s-1] + real :: du ! The difference between the zonal 10 m wind and the zonal ocean flow [L T-1 ~> m s-1] + real :: dv ! The difference between the meridional 10 m wind and the zonal ocean flow [L T-1 ~> m s-1] real :: CD !Wind angle variables @@ -342,12 +360,12 @@ subroutine idealized_hurricane_wind_profile(CS, absf, YY, XX, UOCN, VOCN, Tx, Ty real :: A1 real :: P1 real :: Adir - real :: V_TS - real :: U_TS + real :: V_TS ! Meridional hurricane translation speed [L T-1 ~> m s-1] + real :: U_TS ! Zonal hurricane translation speed [L T-1 ~> m s-1] ! Implementing Holland (1980) parameteric wind profile - Radius = SQRT(XX**2 + YY**2) + radius = SQRT(XX**2 + YY**2) !/ BGR ! rkm - r converted to km for Holland prof. @@ -361,72 +379,87 @@ subroutine idealized_hurricane_wind_profile(CS, absf, YY, XX, UOCN, VOCN, Tx, Ty ! if not comparing to benchmark, then use correct Holland prof. radius_km = radius endif - radiusB = (radius)**CS%Holland_B + radiusB = (US%L_to_m*radius)**CS%Holland_B !/ ! Calculate U10 in the interior (inside of 10x radius of maximum wind), ! while adjusting U10 to 0 outside of 12x radius of maximum wind. - if ( (radius/CS%rad_max_wind .gt. 0.001) .and. & - (radius/CS%rad_max_wind .lt. 10.) ) then - U10 = sqrt(CS%Holland_AxBxDP*exp(-CS%Holland_A/radiusB)/(CS%rho_A*radiusB)& - +0.25*(radius_km*absf)**2) - 0.5*radius_km*absf - elseif ( (radius/CS%rad_max_wind .gt. 10.) .and. & - (radius/CS%rad_max_wind .lt. 15.) ) then - - radius10 = CS%rad_max_wind*10. + if (CS%answers_2018) then + if ( (radius > 0.001*CS%rad_max_wind) .and. (radius < 10.*CS%rad_max_wind) ) then + U10 = sqrt(CS%Holland_AxBxDP*exp(-CS%Holland_A/radiusB) / (CS%rho_a*radiusB) + & + 0.25*(radius_km*absf)**2) - 0.5*radius_km*absf + elseif ( (radius > 10.*CS%rad_max_wind) .and. (radius < 15.*CS%rad_max_wind) ) then + radius10 = CS%rad_max_wind*10. + if (CS%BR_Bench) then + radius_km = radius10/1000. + else + radius_km = radius10 + endif + radiusB = (US%L_to_m*radius10)**CS%Holland_B - if (CS%BR_Bench) then - radius_km = radius10/1000. + U10 = (sqrt(CS%Holland_AxBxDp*exp(-CS%Holland_A/radiusB) / (CS%rho_a*radiusB) + & + 0.25*(radius_km*absf)**2) - 0.5*radius_km*absf) & + * (15. - radius/CS%rad_max_wind)/5. else - radius_km = radius10 + U10 = 0. + endif + else ! This is mathematically equivalent to that is above but more accurate. + if ( (radius > 0.001*CS%rad_max_wind) .and. (radius < 10.*CS%rad_max_wind) ) then + tmp = ( 0.5*radius_km*absf) * (CS%rho_a*radiusB) + U10 = (CS%Holland_AxBxDP * exp(-CS%Holland_A/radiusB)) / & + ( tmp + sqrt(CS%Holland_AxBxDP*exp(-CS%Holland_A/radiusB) * (CS%rho_a*radiusB) + tmp**2) ) + elseif ( (radius > 10.*CS%rad_max_wind) .and. (radius < 15.*CS%rad_max_wind) ) then + radius_km = 10.0 * CS%rad_max_wind + if (CS%BR_Bench) radius_km = radius_km/1000. + radiusB = (10.0*US%L_to_m*CS%rad_max_wind)**CS%Holland_B + tmp = ( 0.5*radius_km*absf) * (CS%rho_a*radiusB) + U10 = (3.0 - radius/(5.0*CS%rad_max_wind)) * (CS%Holland_AxBxDp*exp(-CS%Holland_A/radiusB) ) / & + ( tmp + sqrt(CS%Holland_AxBxDp*exp(-CS%Holland_A/radiusB) * (CS%rho_a*radiusB) + tmp**2) ) + else + U10 = 0.0 endif - radiusB=radius10**CS%Holland_B - - U10 = (sqrt(CS%Holland_AxBxDp*exp(-CS%Holland_A/radiusB)/(CS%rho_A*radiusB)& - +0.25*(radius_km*absf)**2)-0.5*radius_km*absf) & - * (15.-radius/CS%rad_max_wind)/5. - else - U10 = 0. endif - Adir = atan2(YY,xx) + + Adir = atan2(YY,XX) + !\ ! Wind angle model following Zhang and Ulhorn (2012) ! ALPH is inflow angle positive outward. - RSTR = min(10.,radius / CS%rad_max_wind) - A0 = -0.9*RSTR - 0.09*CS%max_windspeed - 14.33 - A1 = -A0*(0.04*RSTR + 0.05*CS%Hurr_translation_spd + 0.14) - P1 = (6.88*RSTR - 9.60*CS%Hurr_translation_spd + 85.31) * CS%Deg2Rad + RSTR = min(10., radius / CS%rad_max_wind) + A0 = -0.9*RSTR - 0.09*US%L_T_to_m_s*CS%max_windspeed - 14.33 + A1 = -A0*(0.04*RSTR + 0.05*US%L_T_to_m_s*CS%hurr_translation_spd + 0.14) + P1 = (6.88*RSTR - 9.60*US%L_T_to_m_s*CS%hurr_translation_spd + 85.31) * CS%Deg2Rad ALPH = A0 - A1*cos(CS%hurr_translation_dir-Adir-P1) - if ( (radius/CS%rad_max_wind.gt.10.) .and.& - (radius/CS%rad_max_wind.lt.15.) ) then - ALPH = ALPH*(15.0-radius/CS%rad_max_wind)/5. - elseif (radius/CS%rad_max_wind.gt.15.) then + if ( (radius > 10.*CS%rad_max_wind) .and.& + (radius < 15.*CS%rad_max_wind) ) then + ALPH = ALPH*(15.0 - radius/CS%rad_max_wind)/5. + elseif (radius > 15.*CS%rad_max_wind) then ALPH = 0.0 endif ALPH = ALPH * CS%Deg2Rad ! Calculate translation speed components - U_TS = CS%hurr_translation_spd/2.*cos(CS%hurr_translation_dir) - V_TS = CS%hurr_translation_spd/2.*sin(CS%hurr_translation_dir) + U_TS = CS%hurr_translation_spd * 0.5*cos(CS%hurr_translation_dir) + V_TS = CS%hurr_translation_spd * 0.5*sin(CS%hurr_translation_dir) ! Set output (relative) winds - dU = U10*sin(Adir-CS%Pi-Alph) - UOCN + U_TS - dV = U10*cos(Adir-Alph) - VOCN + V_TS + dU = U10*sin(Adir-CS%Pi-Alph) - Uocn + U_TS + dV = U10*cos(Adir-Alph) - Vocn + V_TS ! Use a simple drag coefficient as a function of U10 (from Sullivan et al., 2010) du10 = sqrt(du**2+dv**2) - if (du10.lt.11.) then + if (dU10 < 11.0*US%m_s_to_L_T) then Cd = 1.2e-3 - elseif (du10.lt.20.0) then - Cd = (0.49 + 0.065*U10)*1.e-3 + elseif (dU10 < 20.0*US%m_s_to_L_T) then + Cd = (0.49 + 0.065*US%L_T_to_m_s*U10)*1.e-3 else Cd = 1.8e-3 endif ! Compute stress vector - TX = CS%rho_A * Cd * sqrt(du**2 + dV**2) * dU - TY = CS%rho_A * Cd * sqrt(du**2 + dV**2) * dV + TX = US%L_to_Z * CS%rho_a * Cd * sqrt(dU**2 + dV**2) * dU + TY = US%L_to_Z * CS%rho_a * Cd * sqrt(dU**2 + dV**2) * dV end subroutine idealized_hurricane_wind_profile @@ -445,14 +478,22 @@ subroutine SCM_idealized_hurricane_wind_forcing(state, forces, day, G, US, CS) integer :: i, j, is, ie, js, je, Isq, Ieq, Jsq, Jeq integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB real :: pie, Deg2Rad - real :: U10, A, B, C, r, f, du10, rkm ! For wind profile expression - real :: xx, t0 !for location - real :: dp, rB + real :: du10 ! The magnitude of the difference between the 10 m wind and the ocean flow [L T-1 ~> m s-1] + real :: U10 ! The 10 m wind speed [L T-1 ~> m s-1] + real :: A, B, C ! For wind profile expression + real :: rad ! The distance from the hurricane center [L ~> m] + real :: rkm ! The distance from the hurricane center, sometimes scaled to km [L ~> m] or [1000 L ~> km] + real :: f_local ! The local Coriolis parameter [T-1 ~> s-1] + real :: xx ! x-position [L ~> m] + real :: t0 !for location + real :: dP ! The pressure difference across the hurricane [R L2 T-2 ~> Pa] + real :: rB real :: Cd ! Air-sea drag coefficient - real :: Uocn, Vocn ! Surface ocean velocity components - real :: dU, dV ! Air-sea differential motion + real :: Uocn, Vocn ! Surface ocean velocity components [L T-1 ~> m s-1] + real :: dU, dV ! Air-sea differential motion [L T-1 ~> m s-1] !Wind angle variables - real :: Alph,Rstr, A0, A1, P1, Adir, transdir, V_TS, U_TS + real :: Alph,Rstr, A0, A1, P1, Adir, transdir + real :: V_TS, U_TS ! Components of the translation speed [L T-1 ~> m s-1] logical :: BR_Bench ! Bounds for loops and memory allocation is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec @@ -471,79 +512,85 @@ subroutine SCM_idealized_hurricane_wind_forcing(state, forces, day, G, US, CS) t0 = 129600. !TC 'eye' crosses (0,0) at 36 hours| transdir = pie !translation direction (-x) | !------------------------------------------------------| - dp = CS%pressure_ambient - CS%pressure_central - C = CS%max_windspeed / sqrt( DP ) - B = C**2 * CS%rho_a * exp(1.0) - if (BR_Bench) then - ! rho_a reset to value used in generated wind for benchmark test - B = C**2 * 1.2 * exp(1.0) + dP = CS%pressure_ambient - CS%pressure_central + if (CS%answers_2018) then + C = CS%max_windspeed / sqrt( US%R_to_kg_m3*dP ) + B = C**2 * US%R_to_kg_m3*CS%rho_a * exp(1.0) + if (BR_Bench) then ! rho_a reset to value used in generated wind for benchmark test + B = C**2 * 1.2 * exp(1.0) + endif + elseif (BR_Bench) then ! rho_a reset to value used in generated wind for benchmark test + B = (CS%max_windspeed**2 / dP ) * 1.2*US%kg_m3_to_R * exp(1.0) + else + B = (CS%max_windspeed**2 /dP ) * CS%rho_a * exp(1.0) endif - A = (CS%rad_max_wind/1000.)**B - f = US%s_to_T*G%CoriolisBu(is,js) ! f=f(x,y) but in the SCM is constant + + A = (US%L_to_m*CS%rad_max_wind / 1000.)**B + f_local = G%CoriolisBu(is,js) ! f=f(x,y) but in the SCM is constant if (BR_Bench) then - ! f reset to value used in generated wind for benchmark test - f = 5.5659e-05 !### A constant value in s-1. + ! f reset to value used in generated wind for benchmark test + f_local = 5.5659e-05*US%T_to_s endif !/ BR ! Calculate x position as a function of time. - xx = ( t0 - time_type_to_real(day)) * CS%hurr_translation_spd * cos(transdir) - r = sqrt(xx**2 + CS%DY_from_center**2) + xx = US%s_to_T*( t0 - time_type_to_real(day)) * CS%hurr_translation_spd * cos(transdir) + rad = sqrt(xx**2 + CS%dy_from_center**2) !/ BR - ! rkm - r converted to km for Holland prof. + ! rkm - rad converted to km for Holland prof. ! used in km due to error, correct implementation should ! not need rkm, but to match winds w/ experiment this must ! be maintained. Causes winds far from storm center to be a ! couple of m/s higher than the correct Holland prof. if (BR_Bench) then - rkm = r/1000. - rB = (rkm)**B + rkm = rad/1000. + rB = (US%L_to_m*rkm)**B else ! if not comparing to benchmark, then use correct Holland prof. - rkm = r - rB = r**B + rkm = rad + rB = (US%L_to_m*rad)**B endif !/ BR ! Calculate U10 in the interior (inside of 10x radius of maximum wind), ! while adjusting U10 to 0 outside of 12x radius of maximum wind. ! Note that rho_a is set to 1.2 following generated wind for experiment - if (r/CS%rad_max_wind > 0.001 .AND. r/CS%rad_max_wind < 10.) then - U10 = sqrt( A*B*dp*exp(-A/rB)/(1.2*rB) + 0.25*(rkm*f)**2 ) - 0.5*rkm*f - elseif (r/CS%rad_max_wind > 10. .AND. r/CS%rad_max_wind < 12.) then - r=CS%rad_max_wind*10. - if (BR_Bench) then - rkm = r/1000. - rB=rkm**B - else - rkm = r - rB = r**B - endif - U10 = ( sqrt( A*B*dp*exp(-A/rB)/(1.2*rB) + 0.25*(rkm*f)**2 ) - 0.5*rkm*f) & - * (12. - r/CS%rad_max_wind)/2. + if (rad > 0.001*CS%rad_max_wind .AND. rad < 10.*CS%rad_max_wind) then + U10 = sqrt( A*B*dP*exp(-A/rB)/(1.2*US%kg_m3_to_R*rB) + 0.25*(rkm*f_local)**2 ) - 0.5*rkm*f_local + elseif (rad > 10.*CS%rad_max_wind .AND. rad < 12.*CS%rad_max_wind) then + rad=(CS%rad_max_wind)*10. + if (BR_Bench) then + rkm = rad/1000. + rB = (US%L_to_m*rkm)**B + else + rkm = rad + rB = (US%L_to_m*rad)**B + endif + U10 = ( sqrt( A*B*dP*exp(-A/rB)/(1.2*US%kg_m3_to_R*rB) + 0.25*(rkm*f_local)**2 ) - 0.5*rkm*f_local) & + * (12. - rad/CS%rad_max_wind)/2. else - U10 = 0. + U10 = 0. endif - Adir = atan2(CS%DY_from_center,xx) + Adir = atan2(CS%dy_from_center,xx) !/ BR ! Wind angle model following Zhang and Ulhorn (2012) ! ALPH is inflow angle positive outward. - RSTR = min(10.,r / CS%rad_max_wind) - A0 = -0.9*RSTR -0.09*CS%max_windspeed - 14.33 - A1 = -A0 *(0.04*RSTR +0.05*CS%hurr_translation_spd+0.14) - P1 = (6.88*RSTR -9.60*CS%hurr_translation_spd+85.31)*pie/180. + RSTR = min(10., rad / CS%rad_max_wind) + A0 = -0.9*RSTR - 0.09*US%L_T_to_m_s*CS%max_windspeed - 14.33 + A1 = -A0 *(0.04*RSTR + 0.05*US%L_T_to_m_s*CS%hurr_translation_spd + 0.14) + P1 = (6.88*RSTR - 9.60*US%L_T_to_m_s*CS%hurr_translation_spd + 85.31)*pie/180. ALPH = A0 - A1*cos( (TRANSDIR - ADIR ) - P1) - if (r/CS%rad_max_wind > 10. .AND. r/CS%rad_max_wind < 12.) then - ALPH = ALPH* (12. - r/CS%rad_max_wind)/2. - elseif (r/CS%rad_max_wind > 12.) then - ALPH = 0.0 + if (rad > 10.*CS%rad_max_wind .AND. rad < 12.*CS%rad_max_wind) then + ALPH = ALPH* (12. - rad/CS%rad_max_wind)/2. + elseif (rad > 12.*CS%rad_max_wind) then + ALPH = 0.0 endif ALPH = ALPH * Deg2Rad !/BR ! Prepare for wind calculation ! X_TS is component of translation speed added to wind vector ! due to background steering wind. - U_TS = CS%hurr_translation_spd/2.*cos(transdir) - V_TS = CS%hurr_translation_spd/2.*sin(transdir) + U_TS = CS%hurr_translation_spd*0.5*cos(transdir) + V_TS = CS%hurr_translation_spd*0.5*sin(transdir) ! Set the surface wind stresses, in [Pa]. A positive taux ! accelerates the ocean to the (pseudo-)east. @@ -553,9 +600,9 @@ subroutine SCM_idealized_hurricane_wind_forcing(state, forces, day, G, US, CS) !/BR ! Turn off surface current for stress calculation to be ! consistent with test case. - Uocn = 0.!state%u(I,j) - Vocn = 0.!0.25*( (state%v(i,J) + state%v(i+1,J-1)) & - ! +(state%v(i+1,J) + state%v(i,J-1)) ) + Uocn = 0. ! state%u(I,j) + Vocn = 0. ! 0.25*( (state%v(i,J) + state%v(i+1,J-1)) & + ! +(state%v(i+1,J) + state%v(i,J-1)) ) !/BR ! Wind vector calculated from location/direction (sin/cos flipped b/c ! cyclonic wind is 90 deg. phase shifted from position angle). @@ -565,35 +612,41 @@ subroutine SCM_idealized_hurricane_wind_forcing(state, forces, day, G, US, CS) !BR ! Add a simple drag coefficient as a function of U10 | !/----------------------------------------------------| - du10=sqrt(du**2+dv**2) - if (du10 < 11.) then - Cd = 1.2e-3 - elseif (du10 < 20.) then - Cd = (0.49 + 0.065 * U10 )*0.001 + du10 = sqrt(du**2+dv**2) + if (dU10 < 11.0*US%m_s_to_L_T) then + Cd = 1.2e-3 + elseif (dU10 < 20.0*US%m_s_to_L_T) then + if (CS%answers_2018) then + Cd = (0.49 + 0.065 * US%L_T_to_m_s*U10 )*0.001 + else ! Brandon, please verify that this line should use du10 instead of U10 -RWH + Cd = (0.49 + 0.065 * US%L_T_to_m_s*dU10 )*0.001 + endif else - Cd = 0.0018 + Cd = 0.0018 endif - forces%taux(I,j) = CS%rho_a * US%kg_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z * & - G%mask2dCu(I,j) * Cd*sqrt(du**2+dV**2)*dU + forces%taux(I,j) = CS%rho_a * US%L_to_Z * G%mask2dCu(I,j) * Cd*du10*dU enddo ; enddo !/BR ! See notes above do J=js-1,Jeq ; do i=is,ie - Uocn = 0.!0.25*( (state%u(I,j) + state%u(I-1,j+1)) & - ! +(state%u(I-1,j) + state%u(I,j+1)) ) - Vocn = 0.!state%v(i,J) + Uocn = 0. ! 0.25*( (state%u(I,j) + state%u(I-1,j+1)) & + ! +(state%u(I-1,j) + state%u(I,j+1)) ) + Vocn = 0. ! state%v(i,J) dU = U10*sin(Adir-pie-Alph) - Uocn + U_TS dV = U10*cos(Adir-Alph) - Vocn + V_TS du10=sqrt(du**2+dv**2) - if (du10 < 11.) then - Cd = 1.2e-3 - elseif (du10 < 20.) then - Cd = (0.49 + 0.065 * U10 )*0.001 + if (dU10 < 11.0*US%m_s_to_L_T) then + Cd = 1.2e-3 + elseif (dU10 < 20.0*US%m_s_to_L_T) then + if (CS%answers_2018) then + Cd = (0.49 + 0.065 * US%L_T_to_m_s*U10 )*0.001 + else ! Brandon, please verify that this line should use du10 instead of U10 -RWH + Cd = (0.49 + 0.065 * US%L_T_to_m_s*dU10 )*0.001 + endif else - Cd = 0.0018 + Cd = 0.0018 endif - forces%tauy(I,j) = CS%rho_a * US%kg_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z * & - G%mask2dCv(I,j) * Cd*du10*dV + forces%tauy(I,j) = CS%rho_a * US%L_to_Z * G%mask2dCv(I,j) * Cd*dU10*dV enddo ; enddo ! Set the surface friction velocity [m s-1]. ustar is always positive. do j=js,je ; do i=is,ie From bfa0e15e90822174c2517b16e25085a5a004d397 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sun, 9 Feb 2020 10:28:53 -0500 Subject: [PATCH 056/316] Removed unused variable in ePBL_column Removed the unused variable dPEa_dKd_g0 from ePBL_column. All answers are bitwise identical. --- src/parameterizations/vertical/MOM_energetic_PBL.F90 | 11 +++-------- 1 file changed, 3 insertions(+), 8 deletions(-) diff --git a/src/parameterizations/vertical/MOM_energetic_PBL.F90 b/src/parameterizations/vertical/MOM_energetic_PBL.F90 index f8c20682ee..962dcb455e 100644 --- a/src/parameterizations/vertical/MOM_energetic_PBL.F90 +++ b/src/parameterizations/vertical/MOM_energetic_PBL.F90 @@ -709,9 +709,6 @@ subroutine ePBL_column(h, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, B_flux, abs real :: dMKE_src_dK ! The partial derivative of MKE_src with Kddt_h(K) [R Z3 T-2 H-1 ~> J m-3 or J kg-1]. real :: Kd_guess0 ! A first guess of the diapycnal diffusivity [Z2 T-1 ~> m2 s-1]. real :: PE_chg_g0 ! The potential energy change when Kd is Kd_guess0 [R Z3 T-2 ~> J m-2] - !### The following might be unused. - real :: dPEa_dKd_g0 ! The derivative of the change in the potential energy of the column above an interface - ! with the diffusivity when the Kd is Kd_guess0 [R Z T-1 ~> J s m-4] real :: Kddt_h_g0 ! The first guess diapycnal diffusivity times a timestep divided ! by the average thicknesses around a layer [H ~> m or kg m-2]. real :: PE_chg_max ! The maximum PE change for very large values of Kddt_h(K) [R Z3 T-2 ~> J m-2]. @@ -1135,16 +1132,14 @@ subroutine ePBL_column(h, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, B_flux, abs dT_to_dPE_a(k-1), dS_to_dPE_a(k-1), & pres_Z(K), dT_to_dColHt(k), dS_to_dColHt(k), & dT_to_dColHt_a(k-1), dS_to_dColHt_a(k-1), & - PE_chg=PE_chg_g0, dPEc_dKd=dPEa_dKd_g0, dPE_max=PE_chg_max, & - dPEc_dKd_0=dPEc_dKd_Kd0 ) + PE_chg=PE_chg_g0, dPE_max=PE_chg_max, dPEc_dKd_0=dPEc_dKd_Kd0 ) else call find_PE_chg(0.0, Kddt_h_g0, hp_a, h(k), & Th_a(k-1), Sh_a(k-1), Th_b(k), Sh_b(k), & dT_to_dPE_a(k-1), dS_to_dPE_a(k-1), dT_to_dPE(k), dS_to_dPE(k), & pres_Z(K), dT_to_dColHt_a(k-1), dS_to_dColHt_a(k-1), & dT_to_dColHt(k), dS_to_dColHt(k), & - PE_chg=PE_chg_g0, dPEc_dKd=dPEa_dKd_g0, dPE_max=PE_chg_max, & - dPEc_dKd_0=dPEc_dKd_Kd0 ) + PE_chg=PE_chg_g0, dPE_max=PE_chg_max, dPEc_dKd_0=dPEc_dKd_Kd0 ) endif MKE_src = dMKE_max*(1.0 - exp(-Kddt_h_g0 * MKE2_Hharm)) @@ -1821,7 +1816,7 @@ subroutine find_mstar(CS, US, Buoyancy_Flux, UStar, UStar_Mean,& MStar = MStar * MStar_Conv_Red if (present(Langmuir_Number)) then - !### In this call, ustar was previously ustar_mean. Is this change deliberate? + !### In this call, ustar was previously ustar_mean. Is this change deliberate, Brandon? -RWH call mstar_Langmuir(CS, US, Abs_Coriolis, Buoyancy_Flux, UStar, BLD, Langmuir_Number, MStar, & MStar_LT, Convect_Langmuir_Number) endif From db6cf477f25e28db2920751427e9cc782e039d8b Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sun, 9 Feb 2020 10:29:14 -0500 Subject: [PATCH 057/316] +Added the new parameter BULKML_CONV_MOMENTUM_BUG Added the new runtime parameter BULKML_CONV_MOMENTUM_BUG, which enables the runtime selction to correct a bug that causes non-conservation of momentum during mixedlayer convection. Changes to solutions when this is enabled are not very large. By default all answers are bitwise identical, but there are new entries in the MOM_parameter_doc files. --- .../vertical/MOM_bulk_mixed_layer.F90 | 16 +++++++++++++--- 1 file changed, 13 insertions(+), 3 deletions(-) diff --git a/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 b/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 index 2625867849..c910433172 100644 --- a/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 +++ b/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 @@ -111,6 +111,8 @@ module MOM_bulk_mixed_layer !! using SST for temperature of liq_runoff logical :: use_calving_heat_content !< Use SST for temperature of froz_runoff logical :: salt_reject_below_ML !< It true, add salt below mixed layer (layer mode only) + logical :: convect_mom_bug !< If true, use code with a bug that causes a loss of momentum + !! conservation during mixedlayer convection. type(diag_ctrl), pointer :: diag => NULL() !< A structure that is used to regulate the !! timing of diagnostic output. @@ -1123,6 +1125,9 @@ subroutine mixedlayer_convection(h, d_eb, htot, Ttot, Stot, uhtot, vhtot, & T_precip * netMassIn(i) * GV%H_to_RZ * fluxes%C_p * Idt if (associated(tv%TempxPmE)) tv%TempxPmE(i,j) = tv%TempxPmE(i,j) + & T_precip * netMassIn(i) * GV%H_to_RZ + else ! This is a massless column, but zero out the summed variables anyway for safety. + htot(i) = 0.0 ; Ttot(i) = 0.0 ; Stot(i) = 0.0 ; R0_tot(i) = 0.0 ; Rcv_tot = 0.0 + uhtot(i) = 0.0 ; vhtot(i) = 0.0 ; Conv_En(i) = 0.0 ; dKE_FC(i) = 0.0 endif ; enddo ! Now do netMassOut case in this block. @@ -1288,9 +1293,11 @@ subroutine mixedlayer_convection(h, d_eb, htot, Ttot, Stot, uhtot, vhtot, & htot(i) = htot(i) + h_ent h(i,k) = h(i,k) - h_ent d_eb(i,k) = d_eb(i,k) - h_ent - uhtot(i) = u(i,k)*h_ent ; vhtot(i) = v(i,k)*h_ent - !### I think that the line above should instead be: - ! uhtot(i) = uhtot(i) + h_ent*u(i,k) ; vhtot(i) = vhtot(i) + h_ent*v(i,k) + if (CS%convect_mom_bug) then + uhtot(i) = u(i,k)*h_ent ; vhtot(i) = v(i,k)*h_ent + else + uhtot(i) = uhtot(i) + h_ent*u(i,k) ; vhtot(i) = vhtot(i) + h_ent*v(i,k) + endif endif @@ -3568,6 +3575,9 @@ subroutine bulkmixedlayer_init(Time, G, GV, US, param_file, diag, CS) "If true, use the fluxes%calving_Hflx field to set the "//& "heat carried by runoff, instead of using SST*CP*froz_runoff.", & default=.false.) + call get_param(param_file, mdl, "BULKML_CONV_MOMENTUM_BUG", CS%convect_mom_bug, & + "If true, use code with a bug that causes a loss of momentum conservation "//& + "during mixedlayer convection.", default=.true.) call get_param(param_file, mdl, "ALLOW_CLOCKS_IN_OMP_LOOPS", & CS%allow_clocks_in_omp_loops, & From d7663f44a154451fda28ea47ab6b3c56458d3970 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sun, 9 Feb 2020 12:08:12 -0500 Subject: [PATCH 058/316] +Added two new run-time parameters for kappa_shear Added KAPPA_SHEAR_MAX_KAP_SRC_CHG and KAPPA_SHEAR_ALL_LAYER_TKE_BUG as two new runtime parameters for the kappa_shear code. One allows a previously hard-coded constant to be set at runtime, while the other enables a bug to be corrected. By default all answers are bitwise identical. --- .../vertical/MOM_kappa_shear.F90 | 48 +++++++++++++++---- 1 file changed, 40 insertions(+), 8 deletions(-) diff --git a/src/parameterizations/vertical/MOM_kappa_shear.F90 b/src/parameterizations/vertical/MOM_kappa_shear.F90 index 9349cf06d7..b6eba22e14 100644 --- a/src/parameterizations/vertical/MOM_kappa_shear.F90 +++ b/src/parameterizations/vertical/MOM_kappa_shear.F90 @@ -78,6 +78,15 @@ module MOM_kappa_shear ! I can think of no good reason why this should be false. - RWH real :: vel_underflow !< Velocity components smaller than vel_underflow !! are set to 0 [L T-1 ~> m s-1]. + real :: kappa_src_max_chg !< The maximum permitted increase in the kappa source within an + !! iteration relative to the local source [nondim]. This must be + !! greater than 1. The lower limit for the permitted fractional + !! decrease is (1 - 0.5/kappa_src_max_chg). These limits could + !! perhaps be made dynamic with an improved iterative solver. + logical :: all_layer_TKE_bug !< If true, report back the latest estimate of TKE instead of the + !! time average TKE when there is mass in all layers. Otherwise always + !! report the time-averaged TKE, as is currently done when there + !! are some massless layers. ! logical :: layer_stagger = .false. ! If true, do the calculations centered at ! layers, rather than the interfaces. logical :: debug = .false. !< If true, write verbose debugging messages. @@ -301,8 +310,11 @@ subroutine Calculate_kappa_shear(u_in, v_in, h, tv, p_surf, kappa_io, tke_io, & if (nz == nzc) then do K=1,nz+1 kappa_2d(i,K) = kappa_avg(K) - !### Should this be tke_avg? - tke_2d(i,K) = tke(K) + if (CS%all_layer_TKE_bug) then + tke_2d(i,K) = tke(K) + else + tke_2d(i,K) = tke_avg(K) + endif enddo else do K=1,nz+1 @@ -599,8 +611,11 @@ subroutine Calc_kappa_shear_vertex(u_in, v_in, h, T_in, S_in, tv, p_surf, kappa_ if (nz == nzc) then do K=1,nz+1 kappa_2d(I,K,J2) = kappa_avg(K) - !### Should this be tke_avg? - tke_2d(I,K) = tke(K) + if (CS%all_layer_TKE_bug) then + tke_2d(i,K) = tke(K) + else + tke_2d(i,K) = tke_avg(K) + endif enddo else do K=1,nz+1 @@ -752,7 +767,7 @@ subroutine kappa_shear_column(kappa, tke, dt, nzc, f2, surface_pres, & real :: g_R0 ! g_R0 is a rescaled version of g/Rho [Z R-1 T-2 ~> m4 kg-1 s-2]. real :: Norm ! A factor that normalizes two weights to 1 [Z-2 ~> m-2]. real :: tol_dksrc ! Tolerance for the change in the kappa source within an iteration - ! relative to the local source [nondim]. + ! relative to the local source [nondim]. This must be greater than 1. real :: tol2 ! The tolerance for the change in the kappa source within an iteration ! relative to the average local source over previous iterations [nondim]. real :: tol_dksrc_low ! The tolerance for the fractional decrease in ksrc @@ -801,9 +816,15 @@ subroutine kappa_shear_column(kappa, tke, dt, nzc, f2, surface_pres, & gR0 = GV%z_to_H*GV%H_to_Pa g_R0 = (US%L_to_Z**2 * GV%g_Earth) / (GV%Rho0) k0dt = dt*CS%kappa_0 - !### These 3 tolerances are hard-coded and fixed for now. Perhaps these could be made dynamic later? - ! tol_dksrc = 0.5*tol_ksrc_chg ; tol_dksrc_low = 1.0 - 1.0/tol_ksrc_chg ? - tol_dksrc = 10.0 ; tol_dksrc_low = 0.95 ; tol2 = 2.0*CS%kappa_tol_err + + tol_dksrc = CS%kappa_src_max_chg + if (tol_dksrc == 10.0) then + ! This is equivalent to the expression below, but avoids changes at roundoff for the default value. + tol_dksrc_low = 0.95 + else + tol_dksrc_low = (tol_dksrc - 0.5)/tol_dksrc + endif + tol2 = 2.0*CS%kappa_tol_err dt_refinements = 5 ! Selected so that 1/2^dt_refinements < 1-tol_dksrc_low use_temperature = .false. ; if (associated(tv%T)) use_temperature = .true. @@ -2062,6 +2083,12 @@ function kappa_shear_init(Time, G, GV, US, param_file, diag, CS) "components are set to 0. A reasonable value might be "//& "1e-30 m/s, which is less than an Angstrom divided by "//& "the age of the universe.", units="m s-1", default=0.0, scale=US%m_s_to_L_T) + call get_param(param_file, mdl, "KAPPA_SHEAR_MAX_KAP_SRC_CHG", CS%kappa_src_max_chg, & + "The maximum permitted increase in the kappa source within an iteration relative "//& + "to the local source; this must be greater than 1. The lower limit for the "//& + "permitted fractional decrease is (1 - 0.5/kappa_src_max_chg). These limits "//& + "could perhaps be made dynamic with an improved iterative solver.", & + default=10.0, units="nondim") call get_param(param_file, mdl, "DEBUG_KAPPA_SHEAR", CS%debug, & "If true, write debugging data for the kappa-shear code. \n"//& @@ -2072,6 +2099,11 @@ function kappa_shear_init(Time, G, GV, US, param_file, diag, CS) "If true. use an older, dimensionally inconsistent estimate of the "//& "derivative of diffusivity with energy in the Newton's method iteration. "//& "The bug causes undercorrections when dz > 1m.", default=.true.) + call get_param(param_file, mdl, "KAPPA_SHEAR_ALL_LAYER_TKE_BUG", CS%all_layer_TKE_bug, & + "If true, report back the latest estimate of TKE instead of the time average "//& + "TKE when there is mass in all layers. Otherwise always report the time "//& + "averaged TKE, as is currently done when there are some massless layers.", & + default=.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) ! id_clock_project = cpu_clock_id('Ocean KS project', grain=CLOCK_ROUTINE) From bb00dc21de200bd632990773298b876da826b198 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Mon, 10 Feb 2020 18:18:14 -0500 Subject: [PATCH 059/316] Further correction to Idealized_Hurricane Added the additional correction to idealized_hurricane_wind_profile that was noted by @breichl in his review of the previous version of this pull request. This will change answers when IDL_HURR_2018_ANSWERS=False, but is otherwise bitwise identical. --- src/user/Idealized_Hurricane.F90 | 14 +++++++++----- 1 file changed, 9 insertions(+), 5 deletions(-) diff --git a/src/user/Idealized_Hurricane.F90 b/src/user/Idealized_Hurricane.F90 index 61765b2586..ff2a533d99 100644 --- a/src/user/Idealized_Hurricane.F90 +++ b/src/user/Idealized_Hurricane.F90 @@ -450,11 +450,15 @@ subroutine idealized_hurricane_wind_profile(CS, US, absf, YY, XX, UOCN, VOCN, Tx ! Use a simple drag coefficient as a function of U10 (from Sullivan et al., 2010) du10 = sqrt(du**2+dv**2) if (dU10 < 11.0*US%m_s_to_L_T) then - Cd = 1.2e-3 + Cd = 1.2e-3 elseif (dU10 < 20.0*US%m_s_to_L_T) then - Cd = (0.49 + 0.065*US%L_T_to_m_s*U10)*1.e-3 + if (CS%answers_2018) then + Cd = (0.49 + 0.065*US%L_T_to_m_s*U10)*1.e-3 + else + Cd = (0.49 + 0.065*US%L_T_to_m_s*dU10)*1.e-3 + endif else - Cd = 1.8e-3 + Cd = 1.8e-3 endif ! Compute stress vector @@ -618,7 +622,7 @@ subroutine SCM_idealized_hurricane_wind_forcing(state, forces, day, G, US, CS) elseif (dU10 < 20.0*US%m_s_to_L_T) then if (CS%answers_2018) then Cd = (0.49 + 0.065 * US%L_T_to_m_s*U10 )*0.001 - else ! Brandon, please verify that this line should use du10 instead of U10 -RWH + else Cd = (0.49 + 0.065 * US%L_T_to_m_s*dU10 )*0.001 endif else @@ -640,7 +644,7 @@ subroutine SCM_idealized_hurricane_wind_forcing(state, forces, day, G, US, CS) elseif (dU10 < 20.0*US%m_s_to_L_T) then if (CS%answers_2018) then Cd = (0.49 + 0.065 * US%L_T_to_m_s*U10 )*0.001 - else ! Brandon, please verify that this line should use du10 instead of U10 -RWH + else Cd = (0.49 + 0.065 * US%L_T_to_m_s*dU10 )*0.001 endif else From 684e1d2ad2fd24ecc0d12cd5b35be6b4ef06614b Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Mon, 10 Feb 2020 18:38:05 -0500 Subject: [PATCH 060/316] Made two versions of find_limited_slope more similar Converted the version of find_limited_slope in MOM_tracer_Z_init into a function and made the versions of find_overlap and find_limited_slope in midas_vermap.F90 and MOM_tracer_Z_init.F90 almost the same (apart from an inconvenient pair of parentheses). All answers are bitwise identical. --- src/initialization/midas_vertmap.F90 | 53 +++++++--------- src/tracer/MOM_tracer_Z_init.F90 | 91 ++++++++++++++-------------- 2 files changed, 66 insertions(+), 78 deletions(-) diff --git a/src/initialization/midas_vertmap.F90 b/src/initialization/midas_vertmap.F90 index 4bc7ed6707..e6c586ed23 100644 --- a/src/initialization/midas_vertmap.F90 +++ b/src/initialization/midas_vertmap.F90 @@ -20,8 +20,8 @@ module MIDAS_vertmap !> Fill grid edges interface fill_boundaries - module procedure fill_boundaries_real - module procedure fill_boundaries_int + module procedure fill_boundaries_real + module procedure fill_boundaries_int end interface contains @@ -236,7 +236,7 @@ function tracer_z_init(tr_in, z_edges, e, nkml, nkbl, land_fill, wet, nlay, nlev if (kz /= k_bot_prev) then ! Calculate the intra-cell profile. if ((kz < nlevs_data(i,j)) .and. (kz > 1)) then - sl_tr = find_limited_slope(tr_1d, z_edges, kz) + sl_tr = find_limited_slope(tr_1d, z_edges, kz) endif endif if (kz > nlevs_data(i,j)) kz = nlevs_data(i,j) @@ -261,7 +261,7 @@ function tracer_z_init(tr_in, z_edges, e, nkml, nkbl, land_fill, wet, nlay, nlev ! Calculate the intra-cell profile. sl_tr = 0.0 ! ; cur_tr = 0.0 if ((kz < nlevs_data(i,j)) .and. (kz > 1)) then - sl_tr = find_limited_slope(tr_1d, z_edges, kz) + sl_tr = find_limited_slope(tr_1d, z_edges, kz) endif ! This is the piecewise linear form. tr(i,j,k) = tr(i,j,k) + wt(kz) * & @@ -484,13 +484,12 @@ subroutine find_overlap(e, Z_top, Z_bot, k_max, k_start, k_top, k_bot, wt, z1, z real :: Ih, e_c, tot_wt, I_totwt integer :: k - wt(:)=0.0 ; z1(:)=0.0 ; z2(:)=0.0 - k_top = k_start ; k_bot = k_start ; wt(1) = 1.0 ; z1(1) = -0.5 ; z2(1) = 0.5 + wt(:) = 0.0 ; z1(:) = 0.0 ; z2(:) = 0.0 ; k_bot = k_max + wt(1) = 1.0 ; z1(1) = -0.5 ; z2(1) = 0.5 do k=k_start,k_max ; if (e(K+1) < Z_top) exit ; enddo k_top = k - - if (k>k_max) return + if (k_top > k_max) return ! Determine the fractional weights of each layer. ! Note that by convention, e and Z_int decrease with increasing k. @@ -502,7 +501,6 @@ subroutine find_overlap(e, Z_top, Z_bot, k_max, k_start, k_top, k_bot, wt, z1, z z2(k) = (e_c - Z_bot) * Ih else wt(k) = MIN(e(K),Z_top) - e(K+1) ; tot_wt = wt(k) ! These are always > 0. - ! Ih = 0.0 ; if (e(K) /= e(K+1)) Ih = 1.0 / (e(K)-e(K+1)) if (e(K) /= e(K+1)) then z1(k) = (0.5*(e(K)+e(K+1)) - MIN(e(K), Z_top)) / (e(K)-e(K+1)) else ; z1(k) = -0.5 ; endif @@ -528,36 +526,27 @@ subroutine find_overlap(e, Z_top, Z_bot, k_max, k_start, k_top, k_bot, wt, z1, z end subroutine find_overlap -!> This subroutine determines a limited slope for val to be advected with +!> This function determines a limited slope for val to be advected with !! a piecewise limited scheme. function find_limited_slope(val, e, k) result(slope) - real, dimension(:), intent(in) :: val !< An column the values that are being interpolated. + real, dimension(:), intent(in) :: val !< A column of values that are being interpolated, in arbitrary units [A]. real, dimension(:), intent(in) :: e !< A column's interface heights [Z ~> m] or other units. integer, intent(in) :: k !< The layer whose slope is being determined. - real :: slope !< The normalized slope in the intracell distribution of val. + real :: slope !< The normalized slope in the intracell distribution of val [A Z-1 ~> A m-1] or other units. ! Local variables - real :: amn, cmn - real :: d1, d2 + real :: d1, d2 ! Thicknesses in the units of e [Z ~> m]. - if ((val(k)-val(k-1)) * (val(k)-val(k+1)) >= 0.0) then - slope = 0.0 ! ; curvature = 0.0 + d1 = 0.5*(e(K-1)-e(K+1)) ; d2 = 0.5*(e(K)-e(K+2)) + if (((val(k)-val(k-1)) * (val(k)-val(k+1)) >= 0.0) .or. (d1*d2 <= 0.0)) then + slope = 0.0 else - d1 = 0.5*(e(K-1)-e(K+1)) ; d2 = 0.5*(e(K)-e(K+2)) - if (d1*d2 > 0.0) then - slope = ((d1**2)*(val(k+1) - val(k)) + (d2**2)*(val(k) - val(k-1))) * & - (e(K) - e(K+1)) / (d1*d2*(d1+d2)) - ! slope = 0.5*(val(k+1) - val(k-1)) - ! This is S.J. Lin's form of the PLM limiter. - amn = min(abs(slope), 2.0*(max(val(k-1), val(k), val(k+1)) - val(k))) - cmn = 2.0*(val(k) - min(val(k-1), val(k), val(k+1))) - slope = sign(1.0, slope) * min(amn, cmn) - - ! min(abs(slope), 2.0*(max(val(k-1),val(k),val(k+1)) - val(k)), & - ! 2.0*(val(k) - min(val(k-1),val(k),val(k+1)))) - ! curvature = 0.0 - else - slope = 0.0 ! ; curvature = 0.0 - endif + slope = ((d1**2)*(val(k+1) - val(k)) + (d2**2)*(val(k) - val(k-1))) * & + (e(K) - e(K+1)) / (d1*d2*(d1+d2)) + ! slope = 0.5*(val(k+1) - val(k-1)) + ! This is S.J. Lin's form of the PLM limiter. + slope = sign(1.0, slope) * min(abs(slope), & + 2.0*(max(val(k-1), val(k), val(k+1)) - val(k)), & + 2.0*(val(k) - min(val(k-1), val(k), val(k+1)))) endif end function find_limited_slope diff --git a/src/tracer/MOM_tracer_Z_init.F90 b/src/tracer/MOM_tracer_Z_init.F90 index 02275d7ad9..b7e00b4eba 100644 --- a/src/tracer/MOM_tracer_Z_init.F90 +++ b/src/tracer/MOM_tracer_Z_init.F90 @@ -3,7 +3,6 @@ module MOM_tracer_Z_init ! This file is part of MOM6. See LICENSE.md for the license. -!use MOM_diag_to_Z, only : find_overlap, find_limited_slope use MOM_error_handler, only : MOM_error, FATAL, WARNING, MOM_mesg, is_root_pe ! use MOM_file_parser, only : get_param, log_version, param_file_type use MOM_grid, only : ocean_grid_type @@ -73,7 +72,7 @@ function tracer_Z_init(tr, h, filename, tr_name, G, US, missing_val, land_val) logical :: has_edges, use_missing, zero_surface character(len=80) :: loc_msg - integer :: k_top, k_bot, k_bot_prev + integer :: k_top, k_bot, k_bot_prev, k_start integer :: i, j, k, kz, is, ie, js, je, nz, nz_in is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke @@ -140,7 +139,7 @@ function tracer_Z_init(tr, h, filename, tr_name, G, US, missing_val, land_val) e(nz+1) = -G%bathyT(i,j) do k=nz,1,-1 ; e(K) = e(K+1) + dilate * h(i,j,k) ; enddo - ! Create a single-column copy of tr_in. ### CHANGE THIS LATER? + ! Create a single-column copy of tr_in. Efficiency is not an issue here. do k=1,nz_in ; tr_1d(k) = tr_in(i,j,k) ; enddo k_bot = 1 ; k_bot_prev = -1 do k=1,nz @@ -149,18 +148,18 @@ function tracer_Z_init(tr, h, filename, tr_name, G, US, missing_val, land_val) elseif (e(K) < z_edges(nz_in+1)) then tr(i,j,k) = tr_1d(nz_in) else + k_start = k_bot ! The starting point for this search call find_overlap(z_edges, e(K), e(K+1), nz_in, & - k_bot, k_top, k_bot, wt, z1, z2) + k_start, k_top, k_bot, wt, z1, z2) kz = k_top if (kz /= k_bot_prev) then ! Calculate the intra-cell profile. sl_tr = 0.0 ! ; cur_tr = 0.0 - if ((kz < nz_in) .and. (kz > 1)) call & - find_limited_slope(tr_1d, z_edges, sl_tr, kz) + if ((kz < nz_in) .and. (kz > 1)) & + sl_tr = find_limited_slope(tr_1d, z_edges, kz) endif ! This is the piecewise linear form. - tr(i,j,k) = wt(kz) * & - (tr_1d(kz) + 0.5*sl_tr*(z2(kz) + z1(kz))) + tr(i,j,k) = wt(kz) * (tr_1d(kz) + 0.5*sl_tr*(z2(kz) + z1(kz))) ! For the piecewise parabolic form add the following... ! + C1_3*cur_tr*(z2(kz)**2 + z2(kz)*z1(kz) + z1(kz)**2)) do kz=k_top+1,k_bot-1 @@ -170,8 +169,8 @@ function tracer_Z_init(tr, h, filename, tr_name, G, US, missing_val, land_val) kz = k_bot ! Calculate the intra-cell profile. sl_tr = 0.0 ! ; cur_tr = 0.0 - if ((kz < nz_in) .and. (kz > 1)) call & - find_limited_slope(tr_1d, z_edges, sl_tr, kz) + if ((kz < nz_in) .and. (kz > 1)) & + sl_tr = find_limited_slope(tr_1d, z_edges, kz) ! This is the piecewise linear form. tr(i,j,k) = tr(i,j,k) + wt(kz) * & (tr_1d(kz) + 0.5*sl_tr*(z2(kz) + z1(kz))) @@ -215,7 +214,7 @@ function tracer_Z_init(tr, h, filename, tr_name, G, US, missing_val, land_val) e(nz+1) = -G%bathyT(i,j) do k=nz,1,-1 ; e(K) = e(K+1) + dilate * h(i,j,k) ; enddo - ! Create a single-column copy of tr_in. ### CHANGE THIS LATER? + ! Create a single-column copy of tr_in. Efficiency is not an issue here. do k=1,nz_in ; tr_1d(k) = tr_in(i,j,k) ; enddo k_bot = 1 do k=1,nz @@ -224,8 +223,9 @@ function tracer_Z_init(tr, h, filename, tr_name, G, US, missing_val, land_val) elseif (z_edges(nz_in) > e(K)) then tr(i,j,k) = tr_1d(nz_in) else + k_start = k_bot ! The starting point for this search call find_overlap(z_edges, e(K), e(K+1), nz_in-1, & - k_bot, k_top, k_bot, wt, z1, z2) + k_start, k_top, k_bot, wt, z1, z2) kz = k_top if (k_top < nz_in) then @@ -410,20 +410,16 @@ end subroutine read_Z_edges !! with the depth range between Z_top and Z_bot, and the fractional weights !! of each layer. It also calculates the normalized relative depths of the range !! of each layer that overlaps that depth range. - -! ### TODO: Merge with midas_vertmap.F90:find_overlap() subroutine find_overlap(e, Z_top, Z_bot, k_max, k_start, k_top, k_bot, wt, z1, z2) - real, dimension(:), intent(in) :: e !< Column interface heights, in arbitrary units. - real, intent(in) :: Z_top !< Top of range being mapped to, in the units of e. - real, intent(in) :: Z_bot !< Bottom of range being mapped to, in the units of e. - integer, intent(in) :: k_max !< Number of valid layers. - integer, intent(in) :: k_start !< Layer at which to start searching. - integer, intent(inout) :: k_top !< Indices of top layers that overlap with the depth - !! range. - integer, intent(inout) :: k_bot !< Indices of bottom layers that overlap with the - !! depth range. - real, dimension(:), intent(out) :: wt !< Relative weights of each layer from k_top to k_bot. - real, dimension(:), intent(out) :: z1 !< Depth of the top limits of the part of + real, dimension(:), intent(in) :: e !< Column interface heights, [Z ~> m] or other units. + real, intent(in) :: Z_top !< Top of range being mapped to, in the units of e [Z ~> m]. + real, intent(in) :: Z_bot !< Bottom of range being mapped to, in the units of e [Z ~> m]. + integer, intent(in) :: k_max !< Number of valid layers. + integer, intent(in) :: k_start !< Layer at which to start searching. + integer, intent(out) :: k_top !< Indices of top layers that overlap with the depth range. + integer, intent(out) :: k_bot !< Indices of bottom layers that overlap with the depth range. + real, dimension(:), intent(out) :: wt !< Relative weights of each layer from k_top to k_bot [nondim]. + real, dimension(:), intent(out) :: z1 !< Depth of the top limits of the part of !! a layer that contributes to a depth level, relative to the cell center and normalized !! by the cell thickness [nondim]. Note that -1/2 <= z1 < z2 <= 1/2. real, dimension(:), intent(out) :: z2 !< Depths of the bottom limit of the part of @@ -433,17 +429,19 @@ subroutine find_overlap(e, Z_top, Z_bot, k_max, k_start, k_top, k_bot, wt, z1, z real :: Ih, e_c, tot_wt, I_totwt integer :: k - do k=k_start,k_max ; if (e(K+1)k_max) return + if (k_top > k_max) return ! Determine the fractional weights of each layer. ! Note that by convention, e and Z_int decrease with increasing k. - if (e(K+1)<=Z_bot) then + if (e(K+1) <= Z_bot) then wt(k) = 1.0 ; k_bot = k Ih = 0.0 ; if (e(K) /= e(K+1)) Ih = 1.0 / (e(K)-e(K+1)) e_c = 0.5*(e(K)+e(K+1)) - z1(k) = (e_c - MIN(e(K),Z_top)) * Ih + z1(k) = (e_c - MIN(e(K), Z_top)) * Ih z2(k) = (e_c - Z_bot) * Ih else wt(k) = MIN(e(K),Z_top) - e(K+1) ; tot_wt = wt(k) ! These are always > 0. @@ -453,7 +451,7 @@ subroutine find_overlap(e, Z_top, Z_bot, k_max, k_start, k_top, k_bot, wt, z1, z z2(k) = 0.5 k_bot = k_max do k=k_top+1,k_max - if (e(K+1)<=Z_bot) then + if (e(K+1) <= Z_bot) then k_bot = k wt(k) = e(K) - Z_bot ; z1(k) = -0.5 if (e(K) /= e(K+1)) then @@ -466,38 +464,39 @@ subroutine find_overlap(e, Z_top, Z_bot, k_max, k_start, k_top, k_bot, wt, z1, z if (k>=k_bot) exit enddo - I_totwt = 1.0 / tot_wt + I_totwt = 0.0 ; if (tot_wt > 0.0) I_totwt = 1.0 / tot_wt do k=k_top,k_bot ; wt(k) = I_totwt*wt(k) ; enddo endif end subroutine find_overlap -!> This subroutine determines a limited slope for val to be advected with +!> This function determines a limited slope for val to be advected with !! a piecewise limited scheme. -! ### TODO: Merge with midas_vertmap.F90:find_limited_slope() -subroutine find_limited_slope(val, e, slope, k) - real, dimension(:), intent(in) :: val !< A column of values that are being interpolated. - real, dimension(:), intent(in) :: e !< Column interface heights in arbitrary units - real, intent(out) :: slope !< Normalized slope in the intracell distribution of val. - integer, intent(in) :: k !< Layer whose slope is being determined. +function find_limited_slope(val, e, k) result(slope) + real, dimension(:), intent(in) :: val !< A column of values that are being interpolated, in arbitrary units [A]. + real, dimension(:), intent(in) :: e !< A column's interface heights [Z ~> m] or other units. + integer, intent(in) :: k !< The layer whose slope is being determined. + real :: slope !< The normalized slope in the intracell distribution of + !! val [A Z-1 ~> A m-1] or other units. ! Local variables - real :: d1, d2 ! Thicknesses in the units of e. + real :: d1, d2 ! Thicknesses in the units of e [Z ~> m]. d1 = 0.5*(e(K-1)-e(K+1)) ; d2 = 0.5*(e(K)-e(K+2)) if (((val(k)-val(k-1)) * (val(k)-val(k+1)) >= 0.0) .or. (d1*d2 <= 0.0)) then - slope = 0.0 ! ; curvature = 0.0 + slope = 0.0 else - slope = (d1**2*(val(k+1) - val(k)) + d2**2*(val(k) - val(k-1))) * & + ! This line has an extra set of parentheses on the second line, so it gives slightly + ! different answers than the version of find_limited_slope in midas_vertmap.F90. + slope = ((d1**2)*(val(k+1) - val(k)) + (d2**2)*(val(k) - val(k-1))) * & ((e(K) - e(K+1)) / (d1*d2*(d1+d2))) ! slope = 0.5*(val(k+1) - val(k-1)) ! This is S.J. Lin's form of the PLM limiter. - slope = sign(1.0,slope) * min(abs(slope), & - 2.0*(max(val(k-1),val(k),val(k+1)) - val(k)), & - 2.0*(val(k) - min(val(k-1),val(k),val(k+1)))) - ! curvature = 0.0 + slope = sign(1.0, slope) * min(abs(slope), & + 2.0*(max(val(k-1), val(k), val(k+1)) - val(k)), & + 2.0*(val(k) - min(val(k-1), val(k), val(k+1)))) endif -end subroutine find_limited_slope +end function find_limited_slope end module MOM_tracer_Z_init From 08620a939e3c1878ef70bcb083a9642d8f388456 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Tue, 11 Feb 2020 15:14:57 -0500 Subject: [PATCH 061/316] +Add REFERENCE_HEIGHT parameter and G%Z_ref Added a reference mean sealevel value, G%Z_ref, to the ocean_grid_type, including the addition of the runtime parameter REFERENCE_HEIGHT and the removal of the recently added runtime parameter MEAN_SEALEV and the mean_SL entry in the barotropic_CS. The mean sea level used in two optionally linearized terms in the barotropic solver is now taken from G%Z_ref. All answers are bitwise identical. --- src/core/MOM_barotropic.F90 | 51 +++++++++++++++++++------------------ src/core/MOM_grid.F90 | 15 ++++++++--- 2 files changed, 37 insertions(+), 29 deletions(-) diff --git a/src/core/MOM_barotropic.F90 b/src/core/MOM_barotropic.F90 index b8aaae6574..0ccf4d8f3b 100644 --- a/src/core/MOM_barotropic.F90 +++ b/src/core/MOM_barotropic.F90 @@ -237,8 +237,6 @@ module MOM_barotropic logical :: linearized_BT_PV !< If true, the PV and interface thicknesses used !! in the barotropic Coriolis calculation is time !! invariant and linearized. - real :: mean_SL !< A mean sea level that is added to bathyT when - !! linearized_BT_PV is true [Z ~> m] 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 @@ -3899,6 +3897,8 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, ! a restart file to the internal representation in this run. real :: uH_rescale ! A rescaling factor for thickness transports from the representation in ! a restart file to the internal representation in this run. + real :: mean_SL ! The mean sea level that is used along with the bathymetry to estimate the + ! geometry when LINEARIZED_BT_CORIOLIS is true or BT_NONLIN_STRESS is false [Z ~> m]. real, allocatable, dimension(:,:) :: lin_drag_h type(memory_size_type) :: MS type(group_pass_type) :: pass_static_data, pass_q_D_Cor @@ -4177,9 +4177,6 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, "If True, use an order of operations that is not bitwise "//& "rotationally symmetric in the meridional Coriolis term of "//& "the barotropic solver.", default=.false.) - call get_param(param_file, mdl, "MEAN_SEALEV", CS%Mean_SL, & - "A mean sea level that is added to bathyT when LINEARIZED_BT_PV is true.", & - units="m", default=0.0, scale=US%m_to_Z, do_not_log=.not.CS%linearized_BT_PV) ! Initialize a version of the MOM domain that is specific to the barotropic solver. call clone_MOM_domain(G%Domain, CS%BT_Domain, min_halo=wd_halos, symmetric=.true.) @@ -4274,20 +4271,21 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, ALLOC_(CS%D_v_Cor(CS%isdw:CS%iedw,CS%jsdw-1:CS%jedw)) CS%q_D(:,:) = 0.0 ; CS%D_u_Cor(:,:) = 0.0 ; CS%D_v_Cor(:,:) = 0.0 + Mean_SL = G%Z_ref do j=js,je ; do I=is-1,ie - CS%D_u_Cor(I,j) = 0.5 * (max(CS%Mean_SL+G%bathyT(i+1,j),0.0) + max(CS%Mean_SL+G%bathyT(i,j),0.0)) + CS%D_u_Cor(I,j) = 0.5 * (max(Mean_SL+G%bathyT(i+1,j),0.0) + max(Mean_SL+G%bathyT(i,j),0.0)) enddo ; enddo do J=js-1,je ; do i=is,ie - CS%D_v_Cor(i,J) = 0.5 * (max(CS%Mean_SL+G%bathyT(i,j+1),0.0) + max(CS%Mean_SL+G%bathyT(i,j),0.0)) + CS%D_v_Cor(i,J) = 0.5 * (max(Mean_SL+G%bathyT(i,j+1),0.0) + max(Mean_SL+G%bathyT(i,j),0.0)) enddo ; enddo do J=js-1,je ; do I=is-1,ie if (G%mask2dT(i,j)+G%mask2dT(i,j+1)+G%mask2dT(i+1,j)+G%mask2dT(i+1,j+1)>0.) then CS%q_D(I,J) = 0.25 * (CS%BT_Coriolis_scale * G%CoriolisBu(I,J)) * & ((G%areaT(i,j) + G%areaT(i+1,j+1)) + (G%areaT(i+1,j) + G%areaT(i,j+1))) / & - (max(((G%areaT(i,j) * max(CS%Mean_SL+G%bathyT(i,j),0.0) + & - G%areaT(i+1,j+1) * max(CS%Mean_SL+G%bathyT(i+1,j+1),0.0)) + & - (G%areaT(i+1,j) * max(CS%Mean_SL+G%bathyT(i+1,j),0.0) + & - G%areaT(i,j+1) * max(CS%Mean_SL+G%bathyT(i,j+1),0.0))), GV%H_to_Z*GV%H_subroundoff) ) + (max(((G%areaT(i,j) * max(Mean_SL+G%bathyT(i,j),0.0) + & + G%areaT(i+1,j+1) * max(Mean_SL+G%bathyT(i+1,j+1),0.0)) + & + (G%areaT(i+1,j) * max(Mean_SL+G%bathyT(i+1,j),0.0) + & + G%areaT(i,j+1) * max(Mean_SL+G%bathyT(i,j+1),0.0))), GV%H_to_Z*GV%H_subroundoff) ) else ! All four h points are masked out so q_D(I,J) will is meaningless CS%q_D(I,J) = 0. endif @@ -4499,20 +4497,23 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, ! Calculate other constants which are used for btstep. - do j=js,je ; do I=is-1,ie - if (G%mask2dCu(I,j)>0.) then - CS%IDatu(I,j) = G%mask2dCu(I,j) * 2.0 / ((G%bathyT(i+1,j) + G%bathyT(i,j)) + 2.0*CS%Mean_SL) - else ! Both neighboring H points are masked out so IDatu(I,j) is meaningless - CS%IDatu(I,j) = 0. - endif - enddo ; enddo - do J=js-1,je ; do i=is,ie - if (G%mask2dCv(i,J)>0.) then - CS%IDatv(i,J) = G%mask2dCv(i,J) * 2.0 / ((G%bathyT(i,j+1) + G%bathyT(i,j)) + 2.0*CS%Mean_SL) - else ! Both neighboring H points are masked out so IDatv(I,j) is meaningless - CS%IDatv(i,J) = 0. - endif - enddo ; enddo + if (.not.CS%nonlin_stress) then + Mean_SL = G%Z_ref + do j=js,je ; do I=is-1,ie + if (G%mask2dCu(I,j)>0.) then + CS%IDatu(I,j) = G%mask2dCu(I,j) * 2.0 / ((G%bathyT(i+1,j) + G%bathyT(i,j)) + 2.0*Mean_SL) + else ! Both neighboring H points are masked out so IDatu(I,j) is meaningless + CS%IDatu(I,j) = 0. + endif + enddo ; enddo + do J=js-1,je ; do i=is,ie + if (G%mask2dCv(i,J)>0.) then + CS%IDatv(i,J) = G%mask2dCv(i,J) * 2.0 / ((G%bathyT(i,j+1) + G%bathyT(i,j)) + 2.0*Mean_SL) + else ! Both neighboring H points are masked out so IDatv(I,j) is meaningless + CS%IDatv(i,J) = 0. + endif + enddo ; enddo + endif call find_face_areas(Datu, Datv, G, GV, US, CS, MS, halo=1) if ((CS%bound_BT_corr) .and. .not.(use_BT_Cont_type .and. CS%BT_cont_bounds)) then diff --git a/src/core/MOM_grid.F90 b/src/core/MOM_grid.F90 index 1a2d03bd44..10832ffe75 100644 --- a/src/core/MOM_grid.F90 +++ b/src/core/MOM_grid.F90 @@ -138,7 +138,8 @@ module MOM_grid y_axis_units !< The units that are used in labeling the y coordinate axes. real ALLOCABLE_, dimension(NIMEM_,NJMEM_) :: & - bathyT !< Ocean bottom depth at tracer points, in depth units [Z ~> m]. + bathyT !< Ocean bottom depth at tracer points, in depth units [Z ~> m]. + real :: Z_ref !< A reference value for all geometric height fields, such as bathyT [Z ~> m]. logical :: bathymetry_at_vel !< If true, there are separate values for the !! basin depths at velocity points. Otherwise the effects of @@ -194,14 +195,16 @@ subroutine MOM_grid_init(G, param_file, US, HI, global_indexing, bathymetry_at_v !! velocity points. Otherwise the effects of topography !! are entirely determined from thickness points. -! This include declares and sets the variable "version". -#include "version_variable.h" + ! Local variables + real :: mean_SeaLev_scale integer :: isd, ied, jsd, jed, nk integer :: IsdB, IedB, JsdB, JedB integer :: ied_max, jed_max integer :: niblock, njblock, nihalo, njhalo, nblocks, n, i, j logical :: local_indexing ! If false use global index values instead of having ! the data domain on each processor start at 1. + ! This include declares and sets the variable "version". +# include "version_variable.h" integer, allocatable, dimension(:) :: ibegin, iend, jbegin, jend character(len=40) :: mod_nm = "MOM_grid" ! This module's name. @@ -218,9 +221,13 @@ subroutine MOM_grid_init(G, param_file, US, HI, global_indexing, bathymetry_at_v call get_param(param_file, mod_nm, "NJBLOCK", njblock, "The number of blocks "// & "in the y-direction on each processor (for openmp).", default=1, & layoutParam=.true.) - if (present(US)) then ; if (associated(US)) G%US => US ; endif + mean_SeaLev_scale = 1.0 ; if (associated(G%US)) mean_SeaLev_scale = G%US%m_to_Z + call get_param(param_file, mod_nm, "REFERENCE_HEIGHT", G%Z_ref, & + "A reference value for geometric height fields, such as bathyT.", & + units="m", default=0.0, scale=mean_SeaLev_scale) + if (present(HI)) then G%HI = HI From c28e14a21cc508013976ee224cd3018579133a0f Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Wed, 12 Feb 2020 10:33:38 -0500 Subject: [PATCH 062/316] OBC meridional flux flag fix Inside merid_face_thickness of the PPM meridional mass flux calculation, the OBC contribution was incorrectly checking for the u BC flag, OBC%open_u_BCs_exist_globally, rather than the v-point equivalent. This may not have previously been a serious issue, due to the prior error which was incorrectly setting similar flags across all segments rather than individual segments. In any case, this error caused other errors in the current state of the model. This patch corrects the flag name and resolves those errors. --- src/core/MOM_continuity_PPM.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/core/MOM_continuity_PPM.F90 b/src/core/MOM_continuity_PPM.F90 index b361cd7a82..f91f0bcd46 100644 --- a/src/core/MOM_continuity_PPM.F90 +++ b/src/core/MOM_continuity_PPM.F90 @@ -1448,7 +1448,7 @@ subroutine merid_face_thickness(v, h, h_L, h_R, h_v, dt, G, US, LB, vol_CFL, & local_open_BC = .false. if (present(OBC)) then ; if (associated(OBC)) then - local_open_BC = OBC%open_u_BCs_exist_globally + local_open_BC = OBC%open_v_BCs_exist_globally endif ; endif if (local_open_BC) then do n = 1, OBC%number_of_segments From 8ed8a9bd8211e5dccbf630914134a2f3f7b833be Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 12 Feb 2020 15:43:01 -0500 Subject: [PATCH 063/316] +Add enthalpy rescaling factors in unit_scale_type Added factors for power-of-2 rescaling of heat content (or enthalpy) to the unit_scale_type, along with the new run-time parameter Q_RESCALE_POWER. All answers are bitwise identical, but there is a new runtime parameter, some new elements in a transparent public type, and a new optional variable in the MOM restart files. This adds a new entry to the MOM_parameter_doc.debugging files. --- src/framework/MOM_unit_scaling.F90 | 23 +++++++++++++++++++++-- 1 file changed, 21 insertions(+), 2 deletions(-) diff --git a/src/framework/MOM_unit_scaling.F90 b/src/framework/MOM_unit_scaling.F90 index fe7f95fc79..63d89276a0 100644 --- a/src/framework/MOM_unit_scaling.F90 +++ b/src/framework/MOM_unit_scaling.F90 @@ -20,6 +20,8 @@ module MOM_unit_scaling real :: T_to_s !< A constant that translates the units of time to seconds. real :: R_to_kg_m3 !< A constant that translates the units of density to kilograms per meter cubed. real :: kg_m3_to_R !< A constant that translates kilograms per meter cubed to the units of density. + real :: Q_to_J_kg !< A constant that translates the units of enthalpy to Joules per kilogram. + real :: J_kg_to_Q !< A constant that translates Joules per kilogram to the units of enthalpy. ! These are useful combinations of the fundamental scale conversion factors above. real :: Z_to_L !< Convert vertical distances to lateral lengths @@ -29,12 +31,15 @@ module MOM_unit_scaling real :: L_T2_to_m_s2 !< Convert lateral accelerations from L T-2 to m s-2. real :: Z2_T_to_m2_s !< Convert vertical diffusivities from Z2 T-1 to m2 s-1. real :: m2_s_to_Z2_T !< Convert vertical diffusivities from m2 s-1 to Z2 T-1. + real :: W_m2_to_QRZ_T !< Convert heat fluxes from W m-2 to Q R Z T-1. + real :: QRZ_T_to_W_m2 !< Convert heat fluxes from Q R Z T-1 to W m-2. ! These are used for changing scaling across restarts. real :: m_to_Z_restart = 0.0 !< A copy of the m_to_Z that is used in restart files. real :: m_to_L_restart = 0.0 !< A copy of the m_to_L that is used in restart files. real :: s_to_T_restart = 0.0 !< A copy of the s_to_T that is used in restart files. real :: kg_m3_to_R_restart = 0.0 !< A copy of the kg_m3_to_R that is used in restart files. + real :: J_kg_to_Q_restart = 0.0 !< A copy of the J_kg_to_Q that is used in restart files. end type unit_scale_type contains @@ -47,8 +52,8 @@ subroutine unit_scaling_init( param_file, US ) ! This routine initializes a unit_scale_type structure (US). ! Local variables - integer :: Z_power, L_power, T_power, R_power - real :: Z_rescale_factor, L_rescale_factor, T_rescale_factor, R_rescale_factor + integer :: Z_power, L_power, T_power, R_power, Q_power + real :: Z_rescale_factor, L_rescale_factor, T_rescale_factor, R_rescale_factor, Q_rescale_factor ! This include declares and sets the variable "version". # include "version_variable.h" character(len=16) :: mdl = "MOM_unit_scaling" @@ -76,6 +81,10 @@ subroutine unit_scaling_init( param_file, US ) "An integer power of 2 that is used to rescale the model's "//& "intenal units of density. Valid values range from -300 to 300.", & units="nondim", default=0, debuggingParam=.true.) + call get_param(param_file, mdl, "Q_RESCALE_POWER", Q_power, & + "An integer power of 2 that is used to rescale the model's "//& + "intenal units of heat content. Valid values range from -300 to 300.", & + units="nondim", default=0, debuggingParam=.true.) if (abs(Z_power) > 300) call MOM_error(FATAL, "unit_scaling_init: "//& "Z_RESCALE_POWER is outside of the valid range of -300 to 300.") if (abs(L_power) > 300) call MOM_error(FATAL, "unit_scaling_init: "//& @@ -84,6 +93,8 @@ subroutine unit_scaling_init( param_file, US ) "T_RESCALE_POWER is outside of the valid range of -300 to 300.") if (abs(R_power) > 300) call MOM_error(FATAL, "unit_scaling_init: "//& "R_RESCALE_POWER is outside of the valid range of -300 to 300.") + if (abs(Q_power) > 300) call MOM_error(FATAL, "unit_scaling_init: "//& + "Q_RESCALE_POWER is outside of the valid range of -300 to 300.") Z_rescale_factor = 1.0 if (Z_power /= 0) Z_rescale_factor = 2.0**Z_power @@ -105,6 +116,11 @@ subroutine unit_scaling_init( param_file, US ) US%R_to_kg_m3 = 1.0 * R_rescale_factor US%kg_m3_to_R = 1.0 / R_rescale_factor + Q_Rescale_factor = 1.0 + if (Q_power /= 0) Q_Rescale_factor = 2.0**Q_power + US%Q_to_J_kg = 1.0 * Q_Rescale_factor + US%J_kg_to_Q = 1.0 / Q_Rescale_factor + ! These are useful combinations of the fundamental scale conversion factors set above. US%Z_to_L = US%Z_to_m * US%m_to_L US%L_to_Z = US%L_to_m * US%m_to_Z @@ -114,6 +130,8 @@ subroutine unit_scaling_init( param_file, US ) ! It does not look like US%m_s2_to_L_T2 would be used, so it does not exist. US%Z2_T_to_m2_s = US%Z_to_m**2 * US%s_to_T US%m2_s_to_Z2_T = US%m_to_Z**2 * US%T_to_s + US%W_m2_to_QRZ_T = US%J_kg_to_Q * US%kg_m3_to_R * US%m_to_Z * US%T_to_s + US%QRZ_T_to_W_m2 = US%Q_to_J_kg * US%R_to_kg_m3 * US%Z_to_m * US%s_to_T end subroutine unit_scaling_init @@ -126,6 +144,7 @@ subroutine fix_restart_unit_scaling(US) US%m_to_L_restart = US%m_to_L US%s_to_T_restart = US%s_to_T US%kg_m3_to_R_restart = US%kg_m3_to_R + US%J_kg_to_Q_restart = US%J_kg_to_Q end subroutine fix_restart_unit_scaling From a565a6c8166d1a9121ab3fe7ff8a08e77f0123af Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 12 Feb 2020 15:44:35 -0500 Subject: [PATCH 064/316] +Rescaled units of fluxes%C_p and tv%C_p Rescaled heat capacity units in fluxes%C_p and tv%C_p to [Q degC-1], and added a new optional argument, C_p_scaled, to get_MOM_state_elements. Several other routines also now require unit_scale_type arguments. All answers are bitwise identical, although there are changes to some interfaces. --- .../MOM_surface_forcing_gfdl.F90 | 6 +-- config_src/coupled_driver/ocean_model_MOM.F90 | 7 ++- .../ice_solo_driver/MOM_surface_forcing.F90 | 18 +++---- .../ice_solo_driver/user_surface_forcing.F90 | 2 +- config_src/mct_driver/mom_ocean_model_mct.F90 | 3 +- .../mct_driver/mom_surface_forcing_mct.F90 | 6 +-- .../nuopc_driver/mom_ocean_model_nuopc.F90 | 3 +- .../mom_surface_forcing_nuopc.F90 | 6 +-- .../solo_driver/MESO_surface_forcing.F90 | 8 ++-- config_src/solo_driver/MOM_driver.F90 | 2 +- .../solo_driver/MOM_surface_forcing.F90 | 27 ++++------- .../solo_driver/user_surface_forcing.F90 | 16 +++---- src/core/MOM.F90 | 34 ++++++------- src/core/MOM_forcing_type.F90 | 37 +++++++------- src/core/MOM_variables.F90 | 2 +- src/diagnostics/MOM_diagnostics.F90 | 6 +-- src/diagnostics/MOM_sum_output.F90 | 6 +-- .../vertical/MOM_bulk_mixed_layer.F90 | 6 +-- .../vertical/MOM_diabatic_aux.F90 | 24 ++++++---- .../vertical/MOM_diabatic_driver.F90 | 48 ++++++++++--------- .../vertical/MOM_geothermal.F90 | 5 +- src/user/BFB_surface_forcing.F90 | 2 +- src/user/SCM_CVMix_tests.F90 | 4 +- 23 files changed, 139 insertions(+), 139 deletions(-) diff --git a/config_src/coupled_driver/MOM_surface_forcing_gfdl.F90 b/config_src/coupled_driver/MOM_surface_forcing_gfdl.F90 index 9743c7fa3f..66128cae3b 100644 --- a/config_src/coupled_driver/MOM_surface_forcing_gfdl.F90 +++ b/config_src/coupled_driver/MOM_surface_forcing_gfdl.F90 @@ -247,7 +247,7 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, real :: kg_m2_s_conversion ! A combination of unit conversion factors for rescaling ! mass fluxes [R Z s m2 kg-1 T-1 ~> 1]. real :: rhoXcp ! Reference density times heat capacity times unit scaling - ! factors [J T s-1 Z-1 m-2 degC-1 ~> J m-3 degC-1] + ! factors [Q R degC-1 ~> J m-3 degC-1] real :: sign_for_net_FW_bug ! Should be +1. but an old bug can be recovered by using -1. call cpu_clock_begin(id_clock_forcing) @@ -261,7 +261,7 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, isr = is-isd+1 ; ier = ie-isd+1 ; jsr = js-jsd+1 ; jer = je-jsd+1 kg_m2_s_conversion = US%kg_m3_to_R*US%m_to_Z*US%T_to_s - if (CS%restore_temp) rhoXcp = US%R_to_kg_m3*US%Z_to_m*US%s_to_T * CS%Rho0 * fluxes%C_p + if (CS%restore_temp) rhoXcp = CS%Rho0 * fluxes%C_p open_ocn_mask(:,:) = 1.0 pme_adj(:,:) = 0.0 fluxes%vPrecGlobalAdj = 0.0 @@ -411,7 +411,7 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, 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) * & + fluxes%heat_added(i,j) = US%QRZ_T_to_W_m2 * G%mask2dT(i,j) * CS%trestore_mask(i,j) * & rhoXcp * delta_sst * CS%Flux_const ! W m-2 enddo ; enddo endif diff --git a/config_src/coupled_driver/ocean_model_MOM.F90 b/config_src/coupled_driver/ocean_model_MOM.F90 index 1f01845ae4..d6e2bc31bc 100644 --- a/config_src/coupled_driver/ocean_model_MOM.F90 +++ b/config_src/coupled_driver/ocean_model_MOM.F90 @@ -271,8 +271,7 @@ subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, gas_fields_ocn) OS%restart_CSp, Time_in, offline_tracer_mode=OS%offline_tracer_mode, & diag_ptr=OS%diag, count_calls=.true.) call get_MOM_state_elements(OS%MOM_CSp, G=OS%grid, GV=OS%GV, US=OS%US, C_p=OS%C_p, & - use_temp=use_temperature) - OS%fluxes%C_p = OS%C_p + C_p_scaled=OS%fluxes%C_p, use_temp=use_temperature) ! Read all relevant parameters and write them to the model log. call log_version(param_file, mdl, version, "") @@ -1066,9 +1065,9 @@ subroutine ocean_model_data1D_get(OS, Ocean, name, value) select case(name) case('c_p') - value = OS%C_p + value = OS%C_p case default - call MOM_error(FATAL,'get_ocean_grid_data1D: unknown argument name='//name) + call MOM_error(FATAL,'get_ocean_grid_data1D: unknown argument name='//name) end select end subroutine ocean_model_data1D_get diff --git a/config_src/ice_solo_driver/MOM_surface_forcing.F90 b/config_src/ice_solo_driver/MOM_surface_forcing.F90 index b2e26b0c66..1cc638f8f7 100644 --- a/config_src/ice_solo_driver/MOM_surface_forcing.F90 +++ b/config_src/ice_solo_driver/MOM_surface_forcing.F90 @@ -238,11 +238,11 @@ subroutine set_forcing(sfc_state, forcing, fluxes, day_start, day_interval, G, U if ((CS%variable_buoyforce .or. CS%first_call_set_forcing) .and. & (.not.CS%adiabatic)) then if (trim(CS%buoy_config) == "file") then - call buoyancy_forcing_from_files(sfc_state, fluxes, day_center, dt, G, CS) + call buoyancy_forcing_from_files(sfc_state, fluxes, day_center, dt, G, US, CS) elseif (trim(CS%buoy_config) == "zero") then call buoyancy_forcing_zero(sfc_state, fluxes, day_center, dt, G, CS) elseif (trim(CS%buoy_config) == "linear") then - call buoyancy_forcing_linear(sfc_state, fluxes, day_center, dt, G, CS) + call buoyancy_forcing_linear(sfc_state, fluxes, day_center, dt, G, US, CS) elseif (trim(CS%buoy_config) == "MESO") then call MOM_error(FATAL, "MESO forcing is not available with the ice-shelf"//& "version of MOM_surface_forcing.") @@ -590,7 +590,7 @@ end subroutine wind_forcing_from_file !> This subroutine specifies the current surface fluxes of buoyancy, temperature and fresh water !! by reading a file. It may also be modified to add surface fluxes of user provided tracers. -subroutine buoyancy_forcing_from_files(sfc_state, fluxes, day, dt, G, CS) +subroutine buoyancy_forcing_from_files(sfc_state, fluxes, day, dt, G, US, 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 @@ -598,6 +598,7 @@ subroutine buoyancy_forcing_from_files(sfc_state, fluxes, day, dt, G, CS) real, intent(in) :: dt !< The amount of time over which !! the fluxes apply [s] type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(surface_forcing_CS), pointer :: CS !< A pointer to the control structure returned by a !! previous surface_forcing_init call @@ -628,7 +629,7 @@ subroutine buoyancy_forcing_from_files(sfc_state, fluxes, day, dt, G, CS) ! allocate and initialize arrays call buoyancy_forcing_allocate(fluxes, G, CS) - if (CS%use_temperature) rhoXcp = CS%Rho0 * fluxes%C_p + if (CS%use_temperature) rhoXcp = CS%Rho0 * US%Q_to_J_kg*fluxes%C_p Irho0 = 1.0/(US%R_to_kg_m3*CS%Rho0) ! Read the file containing the buoyancy forcing. @@ -731,7 +732,7 @@ subroutine buoyancy_forcing_from_files(sfc_state, fluxes, day, dt, G, CS) fluxes%sw(i,j) = fluxes%sw(i,j) * G%mask2dT(i,j) fluxes%latent(i,j) = fluxes%latent(i,j) * G%mask2dT(i,j) - fluxes%heat_content_lrunoff(i,j) = fluxes%C_p * & + fluxes%heat_content_lrunoff(i,j) = US%Q_to_J_kg*fluxes%C_p * & fluxes%lrunoff(i,j)*sfc_state%SST(i,j) fluxes%latent_evap_diag(i,j) = fluxes%latent_evap_diag(i,j) * G%mask2dT(i,j) fluxes%latent_fprec_diag(i,j) = -US%R_to_kg_m3*US%Z_to_m*US%s_to_T*fluxes%fprec(i,j)*hlf @@ -825,7 +826,7 @@ end subroutine buoyancy_forcing_zero !> 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. -subroutine buoyancy_forcing_linear(sfc_state, fluxes, day, dt, G, CS) +subroutine buoyancy_forcing_linear(sfc_state, fluxes, day, dt, G, US, 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 with pointers to thermodynamic forcing fields @@ -833,6 +834,7 @@ subroutine buoyancy_forcing_linear(sfc_state, fluxes, day, dt, G, CS) 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(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(surface_forcing_CS), pointer :: CS !< A pointer to the control structure returned by a !! previous surface_forcing_init call @@ -877,8 +879,8 @@ subroutine buoyancy_forcing_linear(sfc_state, fluxes, day, dt, G, CS) T_restore = CS%T_south + (CS%T_north-CS%T_south)*y S_restore = CS%S_south + (CS%S_north-CS%S_south)*y if (G%mask2dT(i,j) > 0) then - fluxes%heat_restore(i,j) = G%mask2dT(i,j) * US%Z_to_m*US%s_to_T * & - ((T_Restore - sfc_state%SST(i,j)) * (((US%R_to_kg_m3*CS%Rho0) * fluxes%C_p) * CS%Flux_const)) + fluxes%heat_restore(i,j) = G%mask2dT(i,j) * US%QRZ_T_to_W_m2 * & + ((T_Restore - sfc_state%SST(i,j)) * ((CS%Rho0 * fluxes%C_p) * CS%Flux_const)) fluxes%vprec(i,j) = - (CS%Rho0*CS%Flux_const) * & (S_Restore - sfc_state%SSS(i,j)) / & (0.5*(sfc_state%SSS(i,j) + S_Restore)) diff --git a/config_src/ice_solo_driver/user_surface_forcing.F90 b/config_src/ice_solo_driver/user_surface_forcing.F90 index 57accf2ef5..feb4e2c7fb 100644 --- a/config_src/ice_solo_driver/user_surface_forcing.F90 +++ b/config_src/ice_solo_driver/user_surface_forcing.F90 @@ -249,7 +249,7 @@ subroutine USER_buoyancy_forcing(sfc_state, fluxes, day, dt, G, US, CS) call MOM_error(FATAL, "User_buoyancy_surface_forcing: " // & "Temperature and salinity restoring used without modification." ) - rhoXcp = US%R_to_kg_m3*CS%Rho0 * fluxes%C_p + rhoXcp = US%R_to_kg_m3*CS%Rho0 * US%Q_to_J_kg*fluxes%C_p do j=js,je ; do i=is,ie ! Set Temp_restore and Salin_restore to the temperature (in degC) and ! salinity (in ppt or PSU) that are being restored toward. diff --git a/config_src/mct_driver/mom_ocean_model_mct.F90 b/config_src/mct_driver/mom_ocean_model_mct.F90 index fb98a7b2bf..a62e421723 100644 --- a/config_src/mct_driver/mom_ocean_model_mct.F90 +++ b/config_src/mct_driver/mom_ocean_model_mct.F90 @@ -279,8 +279,7 @@ subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, gas_fields_ocn, i 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, US=OS%US, C_p=OS%C_p, & - use_temp=use_temperature) - OS%fluxes%C_p = OS%C_p + C_p_scaled=OS%fluxes%C_p, use_temp=use_temperature) ! Read all relevant parameters and write them to the model log. call log_version(param_file, mdl, version, "") diff --git a/config_src/mct_driver/mom_surface_forcing_mct.F90 b/config_src/mct_driver/mom_surface_forcing_mct.F90 index 981202eda8..c5f805fd29 100644 --- a/config_src/mct_driver/mom_surface_forcing_mct.F90 +++ b/config_src/mct_driver/mom_surface_forcing_mct.F90 @@ -244,7 +244,7 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, real :: kg_m2_s_conversion !< A combination of unit conversion factors for rescaling !! mass fluxes [R Z s m2 kg-1 T-1 ~> 1]. - real :: C_p !< heat capacity of seawater ( J/(K kg) ) + real :: C_p !< heat capacity of seawater [J kg-1 degC-1] real :: sign_for_net_FW_bug !< Should be +1. but an old bug can be recovered by using -1. call cpu_clock_begin(id_clock_forcing) @@ -258,7 +258,7 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, isr = is-isd+1 ; ier = ie-isd+1 ; jsr = js-jsd+1 ; jer = je-jsd+1 kg_m2_s_conversion = US%kg_m3_to_R*US%m_to_Z*US%T_to_s - C_p = fluxes%C_p + C_p = US%Q_to_J_kg*fluxes%C_p open_ocn_mask(:,:) = 1.0 pme_adj(:,:) = 0.0 fluxes%vPrecGlobalAdj = 0.0 @@ -414,7 +414,7 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, 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) * & - (US%R_to_kg_m3*CS%Rho0*fluxes%C_p) * delta_sst * CS%Flux_const ! W m-2 + (US%Q_to_J_kg*US%R_to_kg_m3*CS%Rho0*fluxes%C_p) * delta_sst * CS%Flux_const ! W m-2 enddo; enddo endif diff --git a/config_src/nuopc_driver/mom_ocean_model_nuopc.F90 b/config_src/nuopc_driver/mom_ocean_model_nuopc.F90 index 240b576669..f584a68a36 100644 --- a/config_src/nuopc_driver/mom_ocean_model_nuopc.F90 +++ b/config_src/nuopc_driver/mom_ocean_model_nuopc.F90 @@ -281,8 +281,7 @@ subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, gas_fields_ocn, i 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, US=OS%US, C_p=OS%C_p, & - use_temp=use_temperature) - OS%fluxes%C_p = OS%C_p + C_p_scaled=OS%fluxes%C_p, use_temp=use_temperature) ! Read all relevant parameters and write them to the model log. call log_version(param_file, mdl, version, "") diff --git a/config_src/nuopc_driver/mom_surface_forcing_nuopc.F90 b/config_src/nuopc_driver/mom_surface_forcing_nuopc.F90 index 270d4e9f4c..f4ff9025eb 100644 --- a/config_src/nuopc_driver/mom_surface_forcing_nuopc.F90 +++ b/config_src/nuopc_driver/mom_surface_forcing_nuopc.F90 @@ -249,7 +249,7 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, real :: kg_m2_s_conversion !< A combination of unit conversion factors for rescaling !! mass fluxes [R Z s m2 kg-1 T-1 ~> 1]. - real :: C_p !< heat capacity of seawater ( J/(K kg) ) + real :: C_p !< heat capacity of seawater [J kg-1 degC-1] real :: sign_for_net_FW_bug !< Should be +1. but an old bug can be recovered by using -1. call cpu_clock_begin(id_clock_forcing) @@ -263,7 +263,7 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, isr = is-isd+1 ; ier = ie-isd+1 ; jsr = js-jsd+1 ; jer = je-jsd+1 kg_m2_s_conversion = US%kg_m3_to_R*US%m_to_Z*US%T_to_s - C_p = fluxes%C_p + C_p = US%Q_to_J_kg*fluxes%C_p open_ocn_mask(:,:) = 1.0 pme_adj(:,:) = 0.0 fluxes%vPrecGlobalAdj = 0.0 @@ -418,7 +418,7 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, 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) * & - (US%R_to_kg_m3*CS%Rho0*fluxes%C_p) * delta_sst * CS%Flux_const ! W m-2 + (US%Q_to_J_kg*US%R_to_kg_m3*CS%Rho0*fluxes%C_p) * delta_sst * CS%Flux_const ! W m-2 enddo ; enddo endif diff --git a/config_src/solo_driver/MESO_surface_forcing.F90 b/config_src/solo_driver/MESO_surface_forcing.F90 index cf59d577d8..0e9bce9676 100644 --- a/config_src/solo_driver/MESO_surface_forcing.F90 +++ b/config_src/solo_driver/MESO_surface_forcing.F90 @@ -81,7 +81,7 @@ subroutine MESO_buoyancy_forcing(sfc_state, fluxes, day, dt, G, US, CS) real :: Salin_restore ! The salinity that is being restored toward [ppt] real :: density_restore ! The potential density that is being restored ! toward [kg m-3]. - real :: rhoXcp ! The mean density times the heat capacity [J m-3 degC-1]. + real :: rhoXcp ! The mean density times the heat capacity [Q R degC-1 ~> J m-3 degC-1]. real :: buoy_rest_const ! A constant relating density anomalies to the ! restoring buoyancy flux [L2 T-3 R-1 ~> m5 s-3 kg-1]. @@ -169,13 +169,13 @@ subroutine MESO_buoyancy_forcing(sfc_state, fluxes, day, dt, G, US, CS) ! call MOM_error(FATAL, "MESO_buoyancy_surface_forcing: " // & ! "Temperature and salinity restoring used without modification." ) - rhoXcp = US%R_to_kg_m3*CS%Rho0 * fluxes%C_p + rhoXcp = CS%Rho0 * fluxes%C_p do j=js,je ; do i=is,ie ! Set Temp_restore and Salin_restore to the temperature (in degC) and ! salinity (in ppt or PSU) that are being restored toward. if (G%mask2dT(i,j) > 0) then - fluxes%heat_added(i,j) = G%mask2dT(i,j) * & - ((CS%T_Restore(i,j) - sfc_state%SST(i,j)) * rhoXcp * US%Z_to_m*US%s_to_T*CS%Flux_const) + fluxes%heat_added(i,j) = G%mask2dT(i,j) * US%QRZ_T_to_W_m2 * & + ((CS%T_Restore(i,j) - sfc_state%SST(i,j)) * rhoXcp * CS%Flux_const) fluxes%vprec(i,j) = - (CS%Rho0 * CS%Flux_const) * & (CS%S_Restore(i,j) - sfc_state%SSS(i,j)) / & (0.5*(sfc_state%SSS(i,j) + CS%S_Restore(i,j))) diff --git a/config_src/solo_driver/MOM_driver.F90 b/config_src/solo_driver/MOM_driver.F90 index cea90b5db4..dfdfeff8ef 100644 --- a/config_src/solo_driver/MOM_driver.F90 +++ b/config_src/solo_driver/MOM_driver.F90 @@ -318,7 +318,7 @@ program MOM_main tracer_flow_CSp=tracer_flow_CSp) endif - call get_MOM_state_elements(MOM_CSp, G=grid, GV=GV, US=US, C_p=fluxes%C_p) + call get_MOM_state_elements(MOM_CSp, G=grid, GV=GV, US=US, C_p_scaled=fluxes%C_p) Master_Time = Time call callTree_waypoint("done initialize_MOM") diff --git a/config_src/solo_driver/MOM_surface_forcing.F90 b/config_src/solo_driver/MOM_surface_forcing.F90 index 56d7d5a846..b8edfc9526 100644 --- a/config_src/solo_driver/MOM_surface_forcing.F90 +++ b/config_src/solo_driver/MOM_surface_forcing.F90 @@ -775,7 +775,7 @@ subroutine buoyancy_forcing_from_files(sfc_state, fluxes, day, dt, G, US, CS) real :: kg_m2_s_conversion ! A combination of unit conversion factors for rescaling ! mass fluxes [R Z s m2 kg-1 T-1 ~> 1]. - real :: rhoXcp ! reference density times heat capacity [J m-3 degC-1] + real :: rhoXcp ! reference density times heat capacity [Q R degC-1 ~> J m-3 degC-1] integer :: time_lev_daily ! time levels to read for fields with daily cycle integer :: time_lev_monthly ! time levels to read for fields with monthly cycle @@ -789,7 +789,7 @@ subroutine buoyancy_forcing_from_files(sfc_state, fluxes, day, dt, G, US, CS) is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec kg_m2_s_conversion = US%kg_m3_to_R*US%m_to_Z*US%T_to_s - if (CS%use_temperature) rhoXcp = US%R_to_kg_m3*CS%Rho0 * fluxes%C_p + if (CS%use_temperature) rhoXcp = CS%Rho0 * fluxes%C_p ! Read the buoyancy forcing file call get_time(day, seconds, days) @@ -988,7 +988,7 @@ subroutine buoyancy_forcing_from_files(sfc_state, fluxes, day, dt, G, US, CS) if (CS%use_temperature) then do j=js,je ; do i=is,ie if (G%mask2dT(i,j) > 0) then - fluxes%heat_added(i,j) = G%mask2dT(i,j) * & + fluxes%heat_added(i,j) = G%mask2dT(i,j) * US%QRZ_T_to_W_m2 * & ((CS%T_Restore(i,j) - sfc_state%SST(i,j)) * rhoXcp * CS%Flux_const_T) fluxes%vprec(i,j) = - (CS%Rho0*CS%Flux_const_S) * & (CS%S_Restore(i,j) - sfc_state%SSS(i,j)) / & @@ -1054,7 +1054,7 @@ subroutine buoyancy_forcing_from_data_override(sfc_state, fluxes, day, dt, G, US ! anomalies [ppt]. real :: kg_m2_s_conversion ! A combination of unit conversion factors for rescaling ! mass fluxes [R Z s m2 kg-1 T-1 ~> 1]. - real :: rhoXcp ! The mean density times the heat capacity [J m-3 degC-1]. + real :: rhoXcp ! The mean density times the heat capacity [Q R degC-1 ~> J m-3 degC-1]. integer :: time_lev_daily ! The time levels to read for fields with integer :: time_lev_monthly ! daily and montly cycles. @@ -1143,14 +1143,14 @@ subroutine buoyancy_forcing_from_data_override(sfc_state, fluxes, day, dt, G, US if (CS%use_temperature) then do j=js,je ; do i=is,ie if (G%mask2dT(i,j) > 0) then - fluxes%heat_added(i,j) = G%mask2dT(i,j) * & + fluxes%heat_added(i,j) = G%mask2dT(i,j) * US%QRZ_T_to_W_m2 * & ((CS%T_Restore(i,j) - sfc_state%SST(i,j)) * rhoXcp * CS%Flux_const_T) fluxes%vprec(i,j) = - (CS%Rho0*CS%Flux_const_S) * & (CS%S_Restore(i,j) - sfc_state%SSS(i,j)) / & (0.5*(sfc_state%SSS(i,j) + CS%S_Restore(i,j))) else fluxes%heat_added(i,j) = 0.0 - fluxes%vprec(i,j) = 0.0 + fluxes%vprec(i,j) = 0.0 endif enddo ; enddo else @@ -1341,7 +1341,7 @@ subroutine buoyancy_forcing_linear(sfc_state, fluxes, day, dt, G, US, CS) T_restore = CS%T_south + (CS%T_north-CS%T_south)*y S_restore = CS%S_south + (CS%S_north-CS%S_south)*y if (G%mask2dT(i,j) > 0) then - fluxes%heat_added(i,j) = G%mask2dT(i,j) * (US%R_to_kg_m3*US%Z_to_m*US%s_to_T) * & + fluxes%heat_added(i,j) = G%mask2dT(i,j) * (US%QRZ_T_to_W_m2) * & ((T_Restore - sfc_state%SST(i,j)) * ((CS%Rho0 * fluxes%C_p) * CS%Flux_const)) fluxes%vprec(i,j) = - (CS%Rho0*CS%Flux_const) * & (S_Restore - sfc_state%SSS(i,j)) / & @@ -1678,7 +1678,7 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, tracer_flow_C "The constant that relates the restoring surface fluxes "//& "to the relative surface anomalies (akin to a piston "//& "velocity). Note the non-MKS units.", & - units="m day-1", scale=US%m_to_Z*US%T_to_s, & + units="m day-1", scale=US%m_to_Z*US%T_to_s / 86400.0, & fail_if_missing=.true., unscaled=flux_const_default) if (CS%use_temperature) then @@ -1686,23 +1686,16 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, tracer_flow_C "The constant that relates the restoring surface temperature "//& "flux to the relative surface anomaly (akin to a piston "//& "velocity). Note the non-MKS units.", & - units="m day-1", scale=1.0, & ! scale=US%m_to_Z*US%T_to_s, + units="m day-1", scale=US%m_to_Z*US%T_to_s / 86400.0, & default=flux_const_default) call get_param(param_file, mdl, "FLUXCONST_S", CS%Flux_const_S, & "The constant that relates the restoring surface salinity "//& "flux to the relative surface anomaly (akin to a piston "//& "velocity). Note the non-MKS units.", & - units="m day-1", scale=US%m_to_Z*US%T_to_s, & + units="m day-1", scale=US%m_to_Z*US%T_to_s / 86400.0, & default=flux_const_default) endif - !### Convert flux constants from m day-1 to m s-1. Folding these into the scaling - ! factors above could change a division into a multiply by a reciprocal, which could - ! change answers at the level of roundoff. - CS%Flux_const = CS%Flux_const / 86400.0 - CS%Flux_const_T = CS%Flux_const_T / 86400.0 - CS%Flux_const_S = CS%Flux_const_S / 86400.0 - if (trim(CS%buoy_config) == "linear") then call get_param(param_file, mdl, "SST_NORTH", CS%T_north, & "With buoy_config linear, the sea surface temperature "//& diff --git a/config_src/solo_driver/user_surface_forcing.F90 b/config_src/solo_driver/user_surface_forcing.F90 index caf862f097..a7a04d292a 100644 --- a/config_src/solo_driver/user_surface_forcing.F90 +++ b/config_src/solo_driver/user_surface_forcing.F90 @@ -129,9 +129,8 @@ subroutine USER_buoyancy_forcing(sfc_state, fluxes, day, dt, G, US, CS) real :: Temp_restore ! The temperature that is being restored toward [degC]. real :: Salin_restore ! The salinity that is being restored toward [ppt] real :: density_restore ! The potential density that is being restored - ! toward [kg m-3]. - real :: rhoXcp ! The mean density times the heat capacity [J m-3 degC-1]. - real :: Rho0_mks ! The mean density in MKS units [kg m-3] + ! toward [R ~> kg m-3]. + real :: rhoXcp ! The mean density times the heat capacity [Q R degC-1 ~> J m-3 degC-1]. real :: buoy_rest_const ! A constant relating density anomalies to the ! restoring buoyancy flux [L2 m3 T-3 kg-1 ~> m5 s-3 kg-1]. @@ -140,7 +139,6 @@ subroutine USER_buoyancy_forcing(sfc_state, fluxes, day, dt, G, US, CS) is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed - Rho0_mks = CS%Rho0 * US%R_to_kg_m3 ! When modifying the code, comment out this error message. It is here ! so that the original (unmodified) version is not accidentally used. @@ -202,14 +200,14 @@ subroutine USER_buoyancy_forcing(sfc_state, fluxes, day, dt, G, US, CS) call MOM_error(FATAL, "User_buoyancy_surface_forcing: " // & "Temperature and salinity restoring used without modification." ) - rhoXcp = Rho0_mks * fluxes%C_p + rhoXcp = CS%Rho0 * fluxes%C_p do j=js,je ; do i=is,ie ! Set Temp_restore and Salin_restore to the temperature (in degC) and ! salinity (in PSU or ppt) that are being restored toward. Temp_restore = 0.0 Salin_restore = 0.0 - fluxes%heat_added(i,j) = (G%mask2dT(i,j) * (rhoXcp * US%Z_to_m*US%s_to_T*CS%Flux_const)) * & + fluxes%heat_added(i,j) = (G%mask2dT(i,j) * (rhoXcp * US%QRZ_T_to_W_m2*CS%Flux_const)) * & (Temp_restore - sfc_state%SST(i,j)) 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)))) @@ -221,14 +219,14 @@ subroutine USER_buoyancy_forcing(sfc_state, fluxes, day, dt, G, US, CS) "Buoyancy restoring used without modification." ) ! The -1 is because density has the opposite sign to buoyancy. - buoy_rest_const = -1.0 * (CS%G_Earth * CS%Flux_const) / Rho0_mks + buoy_rest_const = -1.0 * (CS%G_Earth * CS%Flux_const) / CS%Rho0 do j=js,je ; do i=is,ie ! Set density_restore to an expression for the surface potential ! density [kg m-3] that is being restored toward. - density_restore = 1030.0 + density_restore = 1030.0*US%kg_m3_to_R fluxes%buoy(i,j) = G%mask2dT(i,j) * buoy_rest_const * & - (density_restore - sfc_state%sfc_density(i,j)) + (density_restore - US%kg_m3_to_R*sfc_state%sfc_density(i,j)) enddo ; enddo endif endif ! end RESTOREBUOY diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index 690e5250db..6b3dd27577 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -1817,7 +1817,7 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & "constant. This is only used if ENABLE_THERMODYNAMICS is "//& "true. The default value is from the TEOS-10 definition "//& "of conservative temperature.", units="J kg-1 K-1", & - default=3991.86795711963) + default=3991.86795711963, scale=US%J_kg_to_Q) endif if (use_EOS) call get_param(param_file, "MOM", "P_REF", CS%tv%P_Ref, & "The pressure that is used for calculating the coordinate "//& @@ -1994,11 +1994,11 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & if (CS%tv%T_is_conT) then vd_T = var_desc(name="contemp", units="Celsius", longname="Conservative Temperature", & cmor_field_name="thetao", cmor_longname="Sea Water Potential Temperature", & - conversion=CS%tv%C_p) + conversion=US%Q_to_J_kg*CS%tv%C_p) else vd_T = var_desc(name="temp", units="degC", longname="Potential Temperature", & cmor_field_name="thetao", cmor_longname="Sea Water Potential Temperature", & - conversion=CS%tv%C_p) + conversion=US%Q_to_J_kg*CS%tv%C_p) endif if (CS%tv%S_is_absS) then vd_S = var_desc(name="abssalt",units="g kg-1",longname="Absolute Salinity", & @@ -2012,7 +2012,7 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & if (advect_TS) then S_flux_units = get_tr_flux_units(GV, "psu") ! Could change to "kg m-2 s-1"? - conv2watt = GV%H_to_kg_m2 * CS%tv%C_p + conv2watt = GV%H_to_kg_m2 * US%Q_to_J_kg*CS%tv%C_p if (GV%Boussinesq) then conv2salt = GV%H_to_m ! Could change to GV%H_to_kg_m2 * 0.001? else @@ -2923,7 +2923,7 @@ subroutine extract_surface_state(CS, sfc_state) if (G%mask2dT(i,j)>0.) then ! instantaneous melt_potential [J m-2] - sfc_state%melt_potential(i,j) = CS%tv%C_p * US%R_to_kg_m3*GV%Rho0 * delT(i) + sfc_state%melt_potential(i,j) = US%Q_to_J_kg*CS%tv%C_p * US%R_to_kg_m3*GV%Rho0 * delT(i) endif enddo enddo ! end of j loop @@ -3089,21 +3089,21 @@ end function MOM_state_is_synchronized !> This subroutine offers access to values or pointers to other types from within !! the MOM_control_struct, allowing the MOM_control_struct to be opaque. -subroutine get_MOM_state_elements(CS, G, GV, US, C_p, use_temp) - type(MOM_control_struct), pointer :: CS !< MOM control structure - type(ocean_grid_type), & - optional, pointer :: G !< structure containing metrics and grid info - type(verticalGrid_type), & - optional, pointer :: GV !< structure containing vertical grid info - type(unit_scale_type), & - optional, pointer :: US !< A dimensional unit scaling type - real, optional, intent(out) :: C_p !< The heat capacity - logical, optional, intent(out) :: use_temp !< Indicates whether temperature is a state variable +subroutine get_MOM_state_elements(CS, G, GV, US, C_p, C_p_scaled, use_temp) + type(MOM_control_struct), pointer :: CS !< MOM control structure + type(ocean_grid_type), optional, pointer :: G !< structure containing metrics and grid info + type(verticalGrid_type), optional, pointer :: GV !< structure containing vertical grid info + type(unit_scale_type), optional, pointer :: US !< A dimensional unit scaling type + real, optional, intent(out) :: C_p !< The heat capacity [J kg degC-1] + real, optional, intent(out) :: C_p_scaled !< The heat capacity in scaled + !! units [Q degC-1 ~> J kg degC-1] + logical, optional, intent(out) :: use_temp !< True if temperature is a state variable if (present(G)) G => CS%G if (present(GV)) GV => CS%GV if (present(US)) US => CS%US - if (present(C_p)) C_p = CS%tv%C_p + if (present(C_p)) C_p = CS%US%Q_to_J_kg * CS%tv%C_p + if (present(C_p_scaled)) C_p_scaled = CS%tv%C_p if (present(use_temp)) use_temp = associated(CS%tv%T) end subroutine get_MOM_state_elements @@ -3118,7 +3118,7 @@ subroutine get_ocean_stocks(CS, mass, heat, salt, on_PE_only) if (present(mass)) & mass = global_mass_integral(CS%h, CS%G, CS%GV, on_PE_only=on_PE_only) if (present(heat)) & - heat = CS%tv%C_p * global_mass_integral(CS%h, CS%G, CS%GV, CS%tv%T, on_PE_only=on_PE_only) + heat = CS%US%Q_to_J_kg*CS%tv%C_p * global_mass_integral(CS%h, CS%G, CS%GV, CS%tv%T, on_PE_only=on_PE_only) if (present(salt)) & salt = 1.0e-3 * global_mass_integral(CS%h, CS%G, CS%GV, CS%tv%S, on_PE_only=on_PE_only) diff --git a/src/core/MOM_forcing_type.F90 b/src/core/MOM_forcing_type.F90 index 3dd3af8fbf..5d28e36261 100644 --- a/src/core/MOM_forcing_type.F90 +++ b/src/core/MOM_forcing_type.F90 @@ -441,11 +441,12 @@ subroutine extractFluxes1d(G, GV, US, fluxes, optics, nsw, j, dt_in_T, & !}BGR Ih_limit = 0.0 ; if (FluxRescaleDepth > 0.0) Ih_limit = 1.0 / FluxRescaleDepth - RZ_T_to_W_m2_degC = fluxes%C_p*US%R_to_kg_m3*US%Z_to_m*US%s_to_T - I_Cp = 1.0 / fluxes%C_p - W_m2_to_H_T = 1.0 / (US%s_to_T * GV%H_to_kg_m2 * fluxes%C_p) + ! RZ_T_to_W_m2_degC = US%Q_to_J_kg*fluxes%C_p*US%R_to_kg_m3*US%Z_to_m*US%s_to_T + RZ_T_to_W_m2_degC = US%QRZ_T_to_W_m2*fluxes%C_p + I_Cp = 1.0 / (US%Q_to_J_kg*fluxes%C_p) + W_m2_to_H_T = 1.0 / (US%s_to_T * GV%H_to_kg_m2 * US%Q_to_J_kg * fluxes%C_p) - RZcP_to_H = 1.0 / (GV%H_to_RZ * fluxes%C_p) + RZcP_to_H = 1.0 / (GV%H_to_RZ * US%Q_to_J_kg*fluxes%C_p) is = G%isc ; ie = G%iec ; nz = G%ke @@ -701,9 +702,9 @@ subroutine extractFluxes1d(G, GV, US, fluxes, optics, nsw, j, dt_in_T, & 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_RZ / dt_in_T + fluxes%heat_content_massin(i,j) = -US%Q_to_J_kg*fluxes%C_p * netMassOut(i) * T(i,1) * GV%H_to_RZ / dt_in_T else ! net is "out" - fluxes%heat_content_massin(i,j) = fluxes%C_p * ( netMassInout(i) - netMassOut(i) ) * & + fluxes%heat_content_massin(i,j) = US%Q_to_J_kg*fluxes%C_p * ( netMassInout(i) - netMassOut(i) ) * & T(i,1) * GV%H_to_RZ / dt_in_T endif else @@ -716,9 +717,9 @@ subroutine extractFluxes1d(G, GV, US, fluxes, optics, nsw, j, dt_in_T, & 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_RZ / dt_in_T + fluxes%heat_content_massout(i,j) = US%Q_to_J_kg*fluxes%C_p * netMassOut(i) * T(i,1) * GV%H_to_RZ / dt_in_T else ! net is "out" - fluxes%heat_content_massout(i,j) = -fluxes%C_p * ( netMassInout(i) - netMassOut(i) ) * & + fluxes%heat_content_massout(i,j) = -US%Q_to_J_kg*fluxes%C_p * ( netMassInout(i) - netMassOut(i) ) * & T(i,1) * GV%H_to_RZ / dt_in_T endif else @@ -735,7 +736,7 @@ subroutine extractFluxes1d(G, GV, US, fluxes, optics, nsw, j, dt_in_T, & ! wait until MOM_diabatic_driver.F90. 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) + fluxes%heat_content_lprec(i,j) = US%Q_to_J_kg*fluxes%C_p*fluxes%lprec(i,j)*T(i,1) else fluxes%heat_content_lprec(i,j) = 0.0 endif @@ -746,7 +747,7 @@ subroutine extractFluxes1d(G, GV, US, fluxes, optics, nsw, j, dt_in_T, & ! and until we do so fprec is treated like lprec and enters at SST. -AJA 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) + fluxes%heat_content_fprec(i,j) = US%Q_to_J_kg*fluxes%C_p*fluxes%fprec(i,j)*T(i,1) else fluxes%heat_content_fprec(i,j) = 0.0 endif @@ -755,7 +756,7 @@ subroutine extractFluxes1d(G, GV, US, fluxes, optics, nsw, j, dt_in_T, & ! Following lprec and fprec, water flux due to sea ice melt (seaice_melt) enters at SST - GMM if (associated(fluxes%heat_content_icemelt)) then if (fluxes%seaice_melt(i,j) > 0.0) then - fluxes%heat_content_icemelt(i,j) = fluxes%C_p*fluxes%seaice_melt(i,j)*T(i,1) + fluxes%heat_content_icemelt(i,j) = US%Q_to_J_kg*fluxes%C_p*fluxes%seaice_melt(i,j)*T(i,1) else fluxes%heat_content_icemelt(i,j) = 0.0 endif @@ -766,7 +767,7 @@ subroutine extractFluxes1d(G, GV, US, fluxes, optics, nsw, j, dt_in_T, & ! vprec < 0 means remove water from ocean; set heat_content_vprec in MOM_diabatic_driver.F90 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) + fluxes%heat_content_vprec(i,j) = US%Q_to_J_kg*fluxes%C_p*fluxes%vprec(i,j)*T(i,1) else fluxes%heat_content_vprec(i,j) = 0.0 endif @@ -780,7 +781,7 @@ subroutine extractFluxes1d(G, GV, US, fluxes, optics, nsw, j, dt_in_T, & ! Condensation is assumed to drop into the ocean at the SST, just like lprec. 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) + fluxes%heat_content_cond(i,j) = US%Q_to_J_kg*fluxes%C_p*fluxes%evap(i,j)*T(i,1) else fluxes%heat_content_cond(i,j) = 0.0 endif @@ -789,14 +790,14 @@ subroutine extractFluxes1d(G, GV, US, fluxes, optics, nsw, j, dt_in_T, & ! 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 - fluxes%heat_content_lrunoff(i,j) = fluxes%C_p*fluxes%lrunoff(i,j)*T(i,1) + fluxes%heat_content_lrunoff(i,j) = US%Q_to_J_kg*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 - fluxes%heat_content_frunoff(i,j) = fluxes%C_p*fluxes%frunoff(i,j)*T(i,1) + fluxes%heat_content_frunoff(i,j) = US%Q_to_J_kg*fluxes%C_p*fluxes%frunoff(i,j)*T(i,1) endif endif @@ -2256,7 +2257,7 @@ subroutine forcing_diagnostics(fluxes, sfc_state, G, US, time_end, diag, handles call cpu_clock_begin(handles%id_clock_forcing) - C_p = fluxes%C_p + C_p = US%Q_to_J_kg*fluxes%C_p RZ_T_conversion = US%R_to_kg_m3*US%Z_to_m*US%s_to_T I_dt = 1.0 / (US%T_to_s*fluxes%dt_buoy_accum) ppt2mks = 1e-3 @@ -2536,7 +2537,7 @@ subroutine forcing_diagnostics(fluxes, sfc_state, G, US, time_end, diag, handles if (associated(fluxes%seaice_melt_heat)) res(i,j) = res(i,j) + fluxes%seaice_melt_heat(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 + ! res(i,j) = res(i,j) + sfc_state%TempXpme(i,j) * US%Q_to_J_kg*fluxes%C_p * I_dt !else if (associated(fluxes%heat_content_lrunoff)) & res(i,j) = res(i,j) + RZ_T_conversion*fluxes%heat_content_lrunoff(i,j) @@ -2573,7 +2574,7 @@ subroutine forcing_diagnostics(fluxes, sfc_state, G, US, time_end, diag, handles do j=js,je ; do i=is,ie res(i,j) = 0.0 ! if (associated(sfc_state%TempXpme)) then - ! res(i,j) = res(i,j) + sfc_state%TempXpme(i,j) * fluxes%C_p * I_dt + ! res(i,j) = res(i,j) + sfc_state%TempXpme(i,j) * US%Q_to_J_kg*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) diff --git a/src/core/MOM_variables.F90 b/src/core/MOM_variables.F90 index 5dfa91fee2..6e0c6974bf 100644 --- a/src/core/MOM_variables.F90 +++ b/src/core/MOM_variables.F90 @@ -84,7 +84,7 @@ module MOM_variables real :: P_Ref !< The coordinate-density reference pressure [Pa]. !! This is the pressure used to calculate Rml from !! T and S when eqn_of_state is associated. - real :: C_p !< The heat capacity of seawater [J degC-1 kg-1]. + real :: C_p !< The heat capacity of seawater [Q degC-1 ~> J degC-1 kg-1]. !! When conservative temperature is used, this is !! constant and exactly 3991.86795711963 J degC-1 kg-1. logical :: T_is_conT = .false. !< If true, the temperature variable tv%T is diff --git a/src/diagnostics/MOM_diagnostics.F90 b/src/diagnostics/MOM_diagnostics.F90 index 4caabf94a6..ac7647e66f 100644 --- a/src/diagnostics/MOM_diagnostics.F90 +++ b/src/diagnostics/MOM_diagnostics.F90 @@ -1272,7 +1272,7 @@ subroutine post_surface_thermo_diags(IDs, G, GV, US, diag, dt_int, sfc_state, tv ! post temperature of P-E+R 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) + work_2d(i,j) = tv%TempxPmE(i,j) * (US%Q_to_J_kg*tv%C_p * I_time_int) enddo ; enddo call post_data(IDs%id_Heat_PmE, work_2d, diag, mask=G%mask2dT) endif @@ -1280,7 +1280,7 @@ subroutine post_surface_thermo_diags(IDs, G, GV, US, diag, dt_int, sfc_state, tv ! post geothermal heating or internal heat source/sinks 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) + work_2d(i,j) = tv%internal_heat(i,j) * (US%Q_to_J_kg*tv%C_p * I_time_int) enddo ; enddo call post_data(IDs%id_intern_heat, work_2d, diag, mask=G%mask2dT) endif @@ -2026,7 +2026,7 @@ subroutine write_static_fields(G, GV, US, tv, diag) 'heat capacity of sea water', 'J kg-1 K-1', cmor_field_name='cpocean', & cmor_standard_name='specific_heat_capacity_of_sea_water', & cmor_long_name='specific_heat_capacity_of_sea_water') - if (id > 0) call post_data(id, tv%C_p, diag, .true.) + if (id > 0) call post_data(id, US%Q_to_J_kg*tv%C_p, diag, .true.) endif end subroutine write_static_fields diff --git a/src/diagnostics/MOM_sum_output.F90 b/src/diagnostics/MOM_sum_output.F90 index 6affbab231..757351f467 100644 --- a/src/diagnostics/MOM_sum_output.F90 +++ b/src/diagnostics/MOM_sum_output.F90 @@ -706,7 +706,7 @@ subroutine write_energy(u, v, h, tv, day, n, G, GV, US, CS, tracer_CSp, OBC, dt_ do k=1,nz ; do j=js,je ; do i=is,ie Salt_int(i,j) = Salt_int(i,j) + tv%S(i,j,k) * & (h(i,j,k)*(H_to_kg_m2 * areaTm(i,j))) - Temp_int(i,j) = Temp_int(i,j) + (tv%C_p * tv%T(i,j,k)) * & + Temp_int(i,j) = Temp_int(i,j) + (US%Q_to_J_kg*tv%C_p * tv%T(i,j,k)) * & (h(i,j,k)*(H_to_kg_m2 * areaTm(i,j))) enddo ; enddo ; enddo Salt = reproducing_sum(Salt_int, EFP_sum=salt_EFP) @@ -778,7 +778,7 @@ subroutine write_energy(u, v, h, tv, day, n, G, GV, US, CS, tracer_CSp, OBC, dt_ if (CS%use_temperature) then salin = Salt / mass_tot ; salin_anom = Salt_anom / mass_tot ! salin_chg = Salt_chg / mass_tot - temp = heat / (mass_tot*tv%C_p) ; temp_anom = Heat_anom / (mass_tot*tv%C_p) + temp = heat / (mass_tot*US%Q_to_J_kg*tv%C_p) ; temp_anom = Heat_anom / (mass_tot*US%Q_to_J_kg*tv%C_p) endif En_mass = toten / mass_tot @@ -974,7 +974,7 @@ subroutine accumulate_net_input(fluxes, sfc_state, tv, dt, G, US, CS) integer :: i, j, is, ie, js, je is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec - C_p = fluxes%C_p + C_p = US%Q_to_J_kg*fluxes%C_p RZL2_to_kg = US%L_to_m**2*US%R_to_kg_m3*US%Z_to_m FW_in(:,:) = 0.0 ; FW_input = 0.0 diff --git a/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 b/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 index 2625867849..ef15c89a46 100644 --- a/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 +++ b/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 @@ -1120,7 +1120,7 @@ subroutine mixedlayer_convection(h, d_eb, htot, Ttot, Stot, uhtot, vhtot, & Conv_En(i) = 0.0 ; dKE_FC(i) = 0.0 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_RZ * fluxes%C_p * Idt + T_precip * netMassIn(i) * GV%H_to_RZ * US%Q_to_J_kg*fluxes%C_p * Idt if (associated(tv%TempxPmE)) tv%TempxPmE(i,j) = tv%TempxPmE(i,j) + & T_precip * netMassIn(i) * GV%H_to_RZ endif ; enddo @@ -1168,12 +1168,12 @@ subroutine mixedlayer_convection(h, d_eb, htot, Ttot, Stot, uhtot, vhtot, & d_eb(i,k) = d_eb(i,k) - h_evap ! smg: when resolve the A=B code, we will set - ! heat_content_massout = heat_content_massout - T(i,k)*h_evap*GV%H_to_RZ*fluxes%C_p*Idt + ! heat_content_massout = heat_content_massout - T(i,k)*h_evap*GV%H_to_RZ*US%Q_to_J_kg*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)) & fluxes%heat_content_massout(i,j) = fluxes%heat_content_massout(i,j) - & - T(i,k)*h_evap*GV%H_to_RZ * fluxes%C_p * Idt + T(i,k)*h_evap*GV%H_to_RZ * US%Q_to_J_kg*fluxes%C_p * Idt if (associated(tv%TempxPmE)) tv%TempxPmE(i,j) = tv%TempxPmE(i,j) - & T(i,k)*h_evap*GV%H_to_RZ diff --git a/src/parameterizations/vertical/MOM_diabatic_aux.F90 b/src/parameterizations/vertical/MOM_diabatic_aux.F90 index fe1ae86ee6..95cc752ae3 100644 --- a/src/parameterizations/vertical/MOM_diabatic_aux.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_aux.F90 @@ -1,3 +1,4 @@ + !> Provides functions for some diabatic processes such as fraxil, brine rejection, !! tendency due to surface flux divergence. module MOM_diabatic_aux @@ -99,13 +100,14 @@ module MOM_diabatic_aux !! This subroutine warms any water that is colder than the (currently !! surface) freezing point up to the freezing point and accumulates !! the required heat (in J m-2) in tv%frazil. -subroutine make_frazil(h, tv, G, GV, CS, p_surf, halo) +subroutine make_frazil(h, tv, G, GV, US, CS, p_surf, halo) 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 [H ~> m or kg m-2] type(thermo_var_ptrs), intent(inout) :: tv !< Structure containing pointers to any available !! thermodynamic fields. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(diabatic_aux_CS), intent(in) :: CS !< The control structure returned by a previous !! call to diabatic_aux_init. real, dimension(SZI_(G),SZJ_(G)), & @@ -167,7 +169,7 @@ subroutine make_frazil(h, tv, G, GV, CS, p_surf, halo) if (tv%T(i,j,1) > T_freeze(i)) then ! If frazil had previously been formed, but the surface temperature is now ! above freezing, cool the surface layer with the frazil heat deficit. - hc = (tv%C_p*GV%H_to_kg_m2) * h(i,j,1) + hc = (US%Q_to_J_kg*tv%C_p*GV%H_to_kg_m2) * h(i,j,1) if (tv%frazil(i,j) - hc * (tv%T(i,j,1) - T_freeze(i)) <= 0.0) then tv%T(i,j,1) = tv%T(i,j,1) - tv%frazil(i,j)/hc tv%frazil(i,j) = 0.0 @@ -190,7 +192,7 @@ subroutine make_frazil(h, tv, G, GV, CS, p_surf, halo) T_fr_set = .true. endif - hc = (tv%C_p*GV%H_to_kg_m2) * h(i,j,k) + hc = (US%Q_to_J_kg*tv%C_p*GV%H_to_kg_m2) * h(i,j,k) if (h(i,j,k) <= 10.0*GV%Angstrom_H) then ! Very thin layers should not be cooled by the frazil flux. if (tv%T(i,j,k) < T_freeze(i)) then @@ -660,9 +662,10 @@ subroutine set_pen_shortwave(optics, fluxes, G, GV, CS, opacity_CSp, tracer_flow !! 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(diabatic_aux_CS), pointer :: CS !< Control structure for diabatic_aux + type(diabatic_aux_CS), pointer :: CS !< Control structure for diabatic_aux type(opacity_CS), pointer :: opacity_CSp !< The control structure for the opacity module. - type(tracer_flow_control_CS), pointer :: tracer_flow_CSp !< A pointer to the control structure of the tracer modules. + type(tracer_flow_control_CS), pointer :: tracer_flow_CSp !< A pointer to the control structure + !! organizing the tracer modules. ! Local variables real, dimension(SZI_(G),SZJ_(G)) :: chl_2d !< Vertically uniform chlorophyll-A concentractions [mg m-3] @@ -1115,10 +1118,10 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t ! Diagnostics of heat content associated with mass fluxes 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_RZ * fluxes%C_p * Idt + T2d(i,k) * max(0.,dThickness) * GV%H_to_RZ * US%Q_to_J_kg*fluxes%C_p * Idt 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_RZ * fluxes%C_p * Idt + T2d(i,k) * min(0.,dThickness) * GV%H_to_RZ * US%Q_to_J_kg*fluxes%C_p * Idt if (associated(tv%TempxPmE)) tv%TempxPmE(i,j) = tv%TempxPmE(i,j) + & T2d(i,k) * dThickness * GV%H_to_RZ @@ -1198,10 +1201,10 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t ! Diagnostics of heat content associated with mass fluxes 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_RZ * fluxes%C_p * Idt + T2d(i,k) * max(0.,dThickness) * GV%H_to_RZ * US%Q_to_J_kg*fluxes%C_p * Idt 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_RZ * fluxes%C_p * Idt + T2d(i,k) * min(0.,dThickness) * GV%H_to_RZ * US%Q_to_J_kg*fluxes%C_p * Idt if (associated(tv%TempxPmE)) tv%TempxPmE(i,j) = tv%TempxPmE(i,j) + & T2d(i,k) * dThickness * GV%H_to_RZ @@ -1307,7 +1310,8 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t ! convergence of SW into a layer do k=1,nz ; do i=is,ie - CS%penSW_diag(i,j,k) = (T2d(i,k)-CS%penSW_diag(i,j,k))*h(i,j,k) * US%s_to_T*Idt * tv%C_p * GV%H_to_kg_m2 + CS%penSW_diag(i,j,k) = (T2d(i,k)-CS%penSW_diag(i,j,k))*h(i,j,k) * Idt * tv%C_p * & + US%Q_to_J_kg*GV%H_to_kg_m2*US%s_to_T enddo ; enddo ! Perform a cumulative sum upwards from bottom to diff --git a/src/parameterizations/vertical/MOM_diabatic_driver.F90 b/src/parameterizations/vertical/MOM_diabatic_driver.F90 index f65a0e8eae..5b11e6ed04 100644 --- a/src/parameterizations/vertical/MOM_diabatic_driver.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_driver.F90 @@ -337,14 +337,14 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & endif if (associated(fluxes%p_surf_full)) then - call make_frazil(h, tv, G, GV, CS%diabatic_aux_CSp, fluxes%p_surf_full, halo=CS%halo_TS_diff) + call make_frazil(h, tv, G, GV, US, CS%diabatic_aux_CSp, fluxes%p_surf_full, halo=CS%halo_TS_diff) else - call make_frazil(h, tv, G, GV, CS%diabatic_aux_CSp, halo=CS%halo_TS_diff) + call make_frazil(h, tv, G, GV, US, CS%diabatic_aux_CSp, halo=CS%halo_TS_diff) 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) + call diagnose_frazil_tendency(tv, h, temp_diag, 0.5*dt, G, GV, US, CS) if (CS%id_frazil_h > 0) call post_data(CS%id_frazil_h, h, CS%diag) endif call disable_averaging(CS%diag) @@ -398,13 +398,13 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & endif if (associated(fluxes%p_surf_full)) then - call make_frazil(h, tv, G, GV, CS%diabatic_aux_CSp, fluxes%p_surf_full) + call make_frazil(h, tv, G, GV, US, CS%diabatic_aux_CSp, fluxes%p_surf_full) else - call make_frazil(h, tv, G, GV, CS%diabatic_aux_CSp) + call make_frazil(h, tv, G, GV, US, 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) + call diagnose_frazil_tendency(tv, h, temp_diag, 0.5*dt, G, GV, US, CS) if (CS%id_frazil_h > 0 ) call post_data(CS%id_frazil_h, h, CS%diag) endif @@ -714,7 +714,7 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Tim ! 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, & - US%T_to_s*dt, tv%T, tv%C_p) + US%T_to_s*dt, tv%T, US%Q_to_J_kg*tv%C_p) call KPP_NonLocalTransport_saln(CS%KPP_CSp, G, GV, h, CS%KPP_NLTscalar, CS%KPP_salt_flux, & US%T_to_s*dt, tv%S) call cpu_clock_end(id_clock_kpp) @@ -898,7 +898,7 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Tim ! 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) + call diagnose_boundary_forcing_tendency(tv, h, temp_diag, saln_diag, h_diag, dt, G, GV, US, 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 @@ -992,7 +992,7 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Tim ! the bulk mixed layer scheme. Otherwise in ALE-mode, layer thicknesses will (not?) have changed ! In either case, tendencies should be posted on hold if (CS%diabatic_diff_tendency_diag) then - call diagnose_diabatic_diff_tendency(tv, hold, temp_diag, saln_diag, dt, G, GV, CS) + call diagnose_diabatic_diff_tendency(tv, hold, temp_diag, saln_diag, dt, G, GV, US, CS) if (CS%id_diabatic_diff_h > 0) call post_data(CS%id_diabatic_diff_h, hold, CS%diag, alt_h = hold) endif else @@ -1022,7 +1022,7 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Tim ! In ALE-mode, layer thicknesses do not change. Therefore, we can use h below if (CS%diabatic_diff_tendency_diag) & - call diagnose_diabatic_diff_tendency(tv, h, temp_diag, saln_diag, dt, G, GV, CS) + call diagnose_diabatic_diff_tendency(tv, h, temp_diag, saln_diag, dt, G, GV, US, CS) endif call cpu_clock_end(id_clock_tridiag) @@ -1479,7 +1479,7 @@ subroutine diabatic_ALE(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, ! 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, & - US%T_to_s*dt, tv%T, tv%C_p) + US%T_to_s*dt, tv%T, US%Q_to_J_kg*tv%C_p) call KPP_NonLocalTransport_saln(CS%KPP_CSp, G, GV, h, CS%KPP_NLTscalar, CS%KPP_salt_flux, & US%T_to_s*dt, tv%S) call cpu_clock_end(id_clock_kpp) @@ -1616,7 +1616,7 @@ subroutine diabatic_ALE(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, ! 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) + call diagnose_boundary_forcing_tendency(tv, h, temp_diag, saln_diag, h_diag, dt, G, GV, US, 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 @@ -1705,7 +1705,7 @@ subroutine diabatic_ALE(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, ! 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) + call diagnose_diabatic_diff_tendency(tv, h, temp_diag, saln_diag, dt, G, GV, US, CS) endif call cpu_clock_end(id_clock_tridiag) @@ -2240,7 +2240,7 @@ subroutine layered_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_e ! 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, & - US%T_to_s*dt, tv%T, tv%C_p) + US%T_to_s*dt, tv%T, US%Q_to_J_kg*tv%C_p) call KPP_NonLocalTransport_saln(CS%KPP_CSp, G, GV, h, CS%KPP_NLTscalar, CS%KPP_salt_flux, & US%T_to_s*dt, tv%S) call cpu_clock_end(id_clock_kpp) @@ -2531,7 +2531,7 @@ subroutine layered_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_e ! Note: hold here refers to the thicknesses from before the dual-entraintment when using ! the bulk mixed layer scheme, so tendencies should be posted on hold. if (CS%diabatic_diff_tendency_diag) then - call diagnose_diabatic_diff_tendency(tv, hold, temp_diag, saln_diag, dt, G, GV, CS) + call diagnose_diabatic_diff_tendency(tv, hold, temp_diag, saln_diag, dt, G, GV, US, CS) if (CS%id_diabatic_diff_h > 0) call post_data(CS%id_diabatic_diff_h, hold, CS%diag, alt_h=hold) endif @@ -2909,7 +2909,7 @@ end subroutine adiabatic !> This routine diagnoses tendencies from application of diabatic diffusion !! using ALE algorithm. Note that layer thickness is not altered by !! diabatic diffusion. -subroutine diagnose_diabatic_diff_tendency(tv, h, temp_old, saln_old, dt, G, GV, CS) +subroutine diagnose_diabatic_diff_tendency(tv, h, temp_old, saln_old, dt, G, GV, US, 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 @@ -2917,6 +2917,7 @@ subroutine diagnose_diabatic_diff_tendency(tv, h, temp_old, saln_old, dt, G, GV, real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: temp_old !< temperature prior to diabatic physics real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: saln_old !< salinity prior to diabatic physics [ppt] real, intent(in) :: dt !< time step [T ~> s] + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(diabatic_CS), pointer :: CS !< module control structure ! Local variables @@ -2944,7 +2945,7 @@ subroutine diagnose_diabatic_diff_tendency(tv, h, temp_old, saln_old, dt, G, GV, ! heat tendency 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) + work_3d(i,j,k) = h(i,j,k) * GV%H_to_kg_m2 * US%Q_to_J_kg*tv%C_p * work_3d(i,j,k) enddo ; enddo ; enddo 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) @@ -3001,7 +3002,7 @@ end subroutine diagnose_diabatic_diff_tendency !! Other fluxes contribute 3d in cases when the layers vanish or are very thin, !! 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) + dt, G, GV, US, 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 @@ -3014,6 +3015,7 @@ subroutine diagnose_boundary_forcing_tendency(tv, h, temp_old, saln_old, h_old, real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & intent(in) :: h_old !< thickness prior to boundary flux application [H ~> m or kg m-2] real, intent(in) :: dt !< time step [T ~> s] + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(diabatic_CS), pointer :: CS !< module control structure ! Local variables @@ -3047,7 +3049,8 @@ subroutine diagnose_boundary_forcing_tendency(tv, h, temp_old, saln_old, h_old, ! heat tendency 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)) + work_3d(i,j,k) = US%Q_to_J_kg*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 call post_data(CS%id_boundary_forcing_heat_tend, work_3d, CS%diag, alt_h = h_old) @@ -3097,14 +3100,15 @@ end subroutine diagnose_boundary_forcing_tendency !! This routine is called twice from within subroutine diabatic; at start and at !! end of the diabatic processes. The impacts from frazil are generally a function !! of depth. Hence, when checking heat budget, be sure to remove HFSIFRAZIL from HFDS in k=1. -subroutine diagnose_frazil_tendency(tv, h, temp_old, dt, G, GV, CS) +subroutine diagnose_frazil_tendency(tv, h, temp_old, dt, G, GV, US, CS) type(ocean_grid_type), intent(in) :: G !< ocean grid structure type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure - type(diabatic_CS), pointer :: CS !< module control 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 [H ~> m or kg m-2] real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: temp_old !< temperature prior to frazil formation [degC] real, intent(in) :: dt !< time step [T ~> s] + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(diabatic_CS), pointer :: CS !< module control structure real, dimension(SZI_(G),SZJ_(G)) :: work_2d real :: Idt ! The inverse of the timestep [T-1 ~> s-1] @@ -3124,7 +3128,7 @@ subroutine diagnose_frazil_tendency(tv, h, temp_old, dt, G, GV, CS) ! heat tendency if (CS%id_frazil_heat_tend > 0 .or. CS%id_frazil_heat_tend_2d > 0) then do k=1,nz ; do j=js,je ; do i=is,ie - CS%frazil_heat_diag(i,j,k) = GV%H_to_kg_m2 * tv%C_p * h(i,j,k) * Idt * (tv%T(i,j,k)-temp_old(i,j,k)) + CS%frazil_heat_diag(i,j,k) = GV%H_to_kg_m2 * US%Q_to_J_kg*tv%C_p * h(i,j,k) * Idt * (tv%T(i,j,k)-temp_old(i,j,k)) enddo ; enddo ; enddo if (CS%id_frazil_heat_tend > 0) call post_data(CS%id_frazil_heat_tend, CS%frazil_heat_diag(:,:,:), CS%diag) diff --git a/src/parameterizations/vertical/MOM_geothermal.F90 b/src/parameterizations/vertical/MOM_geothermal.F90 index f11cd374bf..a0f19a46ab 100644 --- a/src/parameterizations/vertical/MOM_geothermal.F90 +++ b/src/parameterizations/vertical/MOM_geothermal.F90 @@ -132,7 +132,7 @@ subroutine geothermal(h, tv, dt, ea, eb, G, GV, US, CS, halo) if (.not.CS%apply_geothermal) return nkmb = GV%nk_rho_varies - Irho_cp = 1.0 / (GV%H_to_kg_m2 * tv%C_p) + Irho_cp = 1.0 / (GV%H_to_kg_m2 * US%Q_to_J_kg*tv%C_p) Angstrom = GV%Angstrom_H H_neglect = GV%H_subroundoff p_ref(:) = tv%P_Ref @@ -337,7 +337,8 @@ subroutine geothermal(h, tv, dt, ea, eb, G, GV, US, CS, halo) ! Calculate heat tendency due to addition and transfer of internal heat if (CS%id_internal_heat_heat_tendency > 0) then - 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) * T_old(i,j,k)) + work_3d(i,j,k) = ((GV%H_to_kg_m2 * US%Q_to_J_kg*tv%C_p) * Idt) * & + (h(i,j,k) * tv%T(i,j,k) - h_old(i,j,k) * T_old(i,j,k)) endif endif ; enddo diff --git a/src/user/BFB_surface_forcing.F90 b/src/user/BFB_surface_forcing.F90 index 6283f07490..4166b16418 100644 --- a/src/user/BFB_surface_forcing.F90 +++ b/src/user/BFB_surface_forcing.F90 @@ -128,7 +128,7 @@ subroutine BFB_buoyancy_forcing(state, fluxes, day, dt, G, US, CS) call MOM_error(FATAL, "User_buoyancy_surface_forcing: " // & "Temperature and salinity restoring used without modification." ) - rhoXcp = US%R_to_kg_m3*US%Z_to_m*US%s_to_T * CS%Rho0 * fluxes%C_p + rhoXcp = US%R_to_kg_m3*US%Z_to_m*US%s_to_T * CS%Rho0 * US%Q_to_J_kg*fluxes%C_p do j=js,je ; do i=is,ie ! Set Temp_restore and Salin_restore to the temperature (in degC) and ! salinity (in ppt) that are being restored toward. diff --git a/src/user/SCM_CVMix_tests.F90 b/src/user/SCM_CVMix_tests.F90 index 960abd49ca..ce891bda20 100644 --- a/src/user/SCM_CVMix_tests.F90 +++ b/src/user/SCM_CVMix_tests.F90 @@ -253,7 +253,7 @@ subroutine SCM_CVMix_tests_buoyancy_forcing(state, fluxes, day, G, US, CS) ! therefore must convert to W/m2 by multiplying ! by Rho0*Cp do J=Jsq,Jeq ; do i=is,ie - fluxes%sens(i,J) = CS%surf_HF * CS%Rho0 * fluxes%C_p + fluxes%sens(i,J) = CS%surf_HF * CS%Rho0 * US%Q_to_J_kg*fluxes%C_p enddo ; enddo endif @@ -273,7 +273,7 @@ subroutine SCM_CVMix_tests_buoyancy_forcing(state, fluxes, day, G, US, CS) ! by Rho0*Cp ! Note diurnal cycle peaks at Noon. fluxes%sw(i,J) = CS%Max_sw * max(0.0,cos(2*PI* & - (time_type_to_real(DAY)/86400.-0.5))) * CS%RHO0 * fluxes%C_p + (time_type_to_real(DAY)/86400.-0.5))) * CS%RHO0 * US%Q_to_J_kg*fluxes%C_p enddo ; enddo endif From e697f893348cfcf375fd4b967e3716c4729da4fd Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 13 Feb 2020 18:21:02 -0500 Subject: [PATCH 065/316] +Rescaled units of fluxes%heat_added to [Q R Z T-1] Rescaled the units of fluxes%heat_added for dimensional consistency testing, and also rescaled the units of several local variables and cancelled out some unit conversion factorss. All answers are bitwise identical. --- .../MOM_surface_forcing_gfdl.F90 | 8 +++---- .../ice_solo_driver/user_surface_forcing.F90 | 10 ++++----- .../mct_driver/mom_surface_forcing_mct.F90 | 22 ++++++++----------- .../mom_surface_forcing_nuopc.F90 | 18 ++++++--------- .../solo_driver/MESO_surface_forcing.F90 | 2 +- .../solo_driver/MOM_surface_forcing.F90 | 8 +++---- .../solo_driver/user_surface_forcing.F90 | 2 +- src/core/MOM_forcing_type.F90 | 14 +++++++----- src/diagnostics/MOM_sum_output.F90 | 2 +- src/user/BFB_surface_forcing.F90 | 4 ++-- 10 files changed, 41 insertions(+), 49 deletions(-) diff --git a/config_src/coupled_driver/MOM_surface_forcing_gfdl.F90 b/config_src/coupled_driver/MOM_surface_forcing_gfdl.F90 index 66128cae3b..81082fbfd5 100644 --- a/config_src/coupled_driver/MOM_surface_forcing_gfdl.F90 +++ b/config_src/coupled_driver/MOM_surface_forcing_gfdl.F90 @@ -339,8 +339,8 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, fluxes%dt_buoy_accum = US%s_to_T*valid_time 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 do j=js,je ; do i=is,ie @@ -411,7 +411,7 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, 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) = US%QRZ_T_to_W_m2 * G%mask2dT(i,j) * CS%trestore_mask(i,j) * & + fluxes%heat_added(i,j) = G%mask2dT(i,j) * CS%trestore_mask(i,j) * & rhoXcp * delta_sst * CS%Flux_const ! W m-2 enddo ; enddo endif @@ -1119,7 +1119,7 @@ subroutine apply_flux_adjustments(G, US, CS, Time, fluxes) call data_override('OCN', 'hflx_adj', temp_at_h(isc:iec,jsc:jec), Time, override=overrode_h) 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) + fluxes%heat_added(i,j) = fluxes%heat_added(i,j) + US%W_m2_to_QRZ_T*temp_at_h(i,j)* G%mask2dT(i,j) enddo ; enddo ; endif ! Not needed? ! if (overrode_h) call pass_var(fluxes%heat_added, G%Domain) diff --git a/config_src/ice_solo_driver/user_surface_forcing.F90 b/config_src/ice_solo_driver/user_surface_forcing.F90 index feb4e2c7fb..b8f26c512c 100644 --- a/config_src/ice_solo_driver/user_surface_forcing.F90 +++ b/config_src/ice_solo_driver/user_surface_forcing.F90 @@ -179,7 +179,7 @@ subroutine USER_buoyancy_forcing(sfc_state, fluxes, day, dt, G, US, CS) real :: Salin_restore ! The salinity that is being restored toward [ppt] real :: density_restore ! The potential density that is being restored ! toward [kg m-3]. - real :: rhoXcp ! The mean density times the heat capacity [J m-3 degC-1]. + real :: rhoXcp ! The mean density times the heat capacity [Q R degC-1 ~> J m-3 degC-1]. real :: buoy_rest_const ! A constant relating density anomalies to the ! restoring buoyancy flux [L2 T-3 R-1 ~> m5 s-3 kg-1]. @@ -249,14 +249,14 @@ subroutine USER_buoyancy_forcing(sfc_state, fluxes, day, dt, G, US, CS) call MOM_error(FATAL, "User_buoyancy_surface_forcing: " // & "Temperature and salinity restoring used without modification." ) - rhoXcp = US%R_to_kg_m3*CS%Rho0 * US%Q_to_J_kg*fluxes%C_p + rhoXcp = CS%Rho0 * fluxes%C_p do j=js,je ; do i=is,ie ! Set Temp_restore and Salin_restore to the temperature (in degC) and ! salinity (in ppt or PSU) that are being restored toward. Temp_restore = 0.0 Salin_restore = 0.0 - fluxes%heat_added(i,j) = (G%mask2dT(i,j) * (rhoXcp * US%Z_to_m*US%s_to_T*CS%Flux_const)) * & + fluxes%heat_added(i,j) = (G%mask2dT(i,j) * (rhoXcp * CS%Flux_const)) * & (Temp_restore - sfc_state%SST(i,j)) 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)))) @@ -332,9 +332,7 @@ subroutine USER_surface_forcing_init(Time, G, US, param_file, diag, CS) "The constant that relates the restoring surface fluxes "//& "to the relative surface anomalies (akin to a piston "//& "velocity). Note the non-MKS units.", & - units="m day-1", scale=US%m_to_Z*US%T_to_s, fail_if_missing=.true.) - ! Convert CS%Flux_const from m day-1 to m s-1. - CS%Flux_const = CS%Flux_const / 86400.0 + units="m day-1", scale=US%m_to_Z*US%T_to_s/86400.0, fail_if_missing=.true.) endif end subroutine USER_surface_forcing_init diff --git a/config_src/mct_driver/mom_surface_forcing_mct.F90 b/config_src/mct_driver/mom_surface_forcing_mct.F90 index c5f805fd29..538faad4de 100644 --- a/config_src/mct_driver/mom_surface_forcing_mct.F90 +++ b/config_src/mct_driver/mom_surface_forcing_mct.F90 @@ -104,7 +104,7 @@ module MOM_surface_forcing_mct !! 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] + real :: Flux_const !< piston velocity for surface restoring [Z T-1 ~> m s-1] 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 @@ -341,8 +341,8 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, fluxes%dt_buoy_accum = US%s_to_T*valid_time 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 do j=js,je ; do i=is,ie @@ -364,7 +364,7 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, 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*US%m_to_Z*US%T_to_s*CS%Flux_const)* & + fluxes%salt_flux(i,j) = 1.e-3*G%mask2dT(i,j) * (CS%Rho0*CS%Flux_const)* & (CS%basin_mask(i,j)*open_ocn_mask(i,j)*CS%srestore_mask(i,j)) *delta_sss ! R Z T-1 ~> kg Salt m-2 s-1 enddo; enddo if (CS%adjust_net_srestore_to_zero) then @@ -386,7 +386,7 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, delta_sss = sfc_state%SSS(i,j) - data_restore(i,j) delta_sss = sign(1.0,delta_sss)*min(abs(delta_sss),CS%max_delta_srestore) fluxes%vprec(i,j) = (CS%basin_mask(i,j)*open_ocn_mask(i,j)*CS%srestore_mask(i,j))* & - (US%m_to_Z*US%T_to_s * CS%Rho0*CS%Flux_const) * & + (CS%Rho0*CS%Flux_const) * & delta_sss / (0.5*(sfc_state%SSS(i,j) + data_restore(i,j))) endif enddo; enddo @@ -414,7 +414,7 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, 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) * & - (US%Q_to_J_kg*US%R_to_kg_m3*CS%Rho0*fluxes%C_p) * delta_sst * CS%Flux_const ! W m-2 + (CS%Rho0*fluxes%C_p) * delta_sst * CS%Flux_const ! W m-2 enddo; enddo endif @@ -898,7 +898,7 @@ subroutine apply_flux_adjustments(G, US, CS, Time, fluxes) call data_override('OCN', 'hflx_adj', temp_at_h(isc:iec,jsc:jec), Time, override=overrode_h) 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) + fluxes%heat_added(i,j) = fluxes%heat_added(i,j) + US%W_m2_to_QRZ_T*temp_at_h(i,j)* G%mask2dT(i,j) enddo ; enddo ; endif ! Not needed? ! if (overrode_h) call pass_var(fluxes%heat_added, G%Domain) @@ -1127,7 +1127,7 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, restore_salt, call get_param(param_file, mdl, "FLUXCONST", CS%Flux_const, & "The constant that relates the restoring surface fluxes "//& "to the relative surface anomalies (akin to a piston "//& - "velocity). Note the non-MKS units.", units="m day-1", & + "velocity). Note the non-MKS units.", units="m day-1", scale=US%m_to_Z*US%T_to_s/86400.0, & 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.", & @@ -1136,8 +1136,6 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, restore_salt, "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 "//& @@ -1175,7 +1173,7 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, restore_salt, call get_param(param_file, mdl, "FLUXCONST", CS%Flux_const, & "The constant that relates the restoring surface fluxes "//& "to the relative surface anomalies (akin to a piston "//& - "velocity). Note the non-MKS units.", units="m day-1", & + "velocity). Note the non-MKS units.", units="m day-1", scale=US%m_to_Z*US%T_to_s / 86400.0, & 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.", & @@ -1184,8 +1182,6 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, restore_salt, "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.", & diff --git a/config_src/nuopc_driver/mom_surface_forcing_nuopc.F90 b/config_src/nuopc_driver/mom_surface_forcing_nuopc.F90 index f4ff9025eb..6446eca424 100644 --- a/config_src/nuopc_driver/mom_surface_forcing_nuopc.F90 +++ b/config_src/nuopc_driver/mom_surface_forcing_nuopc.F90 @@ -108,7 +108,7 @@ module MOM_surface_forcing_nuopc !! 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] + real :: Flux_const !< piston velocity for surface restoring [Z T-1 ~> m s-1] 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 @@ -368,7 +368,7 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, 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*US%m_to_Z*US%T_to_s*CS%Flux_const)* & + 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 if (CS%adjust_net_srestore_to_zero) then @@ -390,7 +390,7 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, delta_sss = sfc_state%SSS(i,j) - data_restore(i,j) delta_sss = sign(1.0,delta_sss)*min(abs(delta_sss),CS%max_delta_srestore) fluxes%vprec(i,j) = (CS%basin_mask(i,j)*open_ocn_mask(i,j)*CS%srestore_mask(i,j))* & - (US%m_to_Z*US%T_to_s * CS%Rho0*CS%Flux_const) * & + (CS%Rho0*CS%Flux_const) * & delta_sss / (0.5*(sfc_state%SSS(i,j) + data_restore(i,j))) endif enddo ; enddo @@ -418,7 +418,7 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, 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) * & - (US%Q_to_J_kg*US%R_to_kg_m3*CS%Rho0*fluxes%C_p) * delta_sst * CS%Flux_const ! W m-2 + (CS%Rho0*fluxes%C_p) * delta_sst * CS%Flux_const ! Q R Z T-1 ~> W m-2 enddo ; enddo endif @@ -893,7 +893,7 @@ subroutine apply_flux_adjustments(G, US, CS, Time, fluxes) call data_override('OCN', 'hflx_adj', temp_at_h(isc:iec,jsc:jec), Time, override=overrode_h) 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) + fluxes%heat_added(i,j) = fluxes%heat_added(i,j) + US%W_m2_to_QRZ_T*temp_at_h(i,j)* G%mask2dT(i,j) enddo ; enddo ; endif ! Not needed? ! if (overrode_h) call pass_var(fluxes%heat_added, G%Domain) @@ -1121,7 +1121,7 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, restore_salt, call get_param(param_file, mdl, "FLUXCONST", CS%Flux_const, & "The constant that relates the restoring surface fluxes "//& "to the relative surface anomalies (akin to a piston "//& - "velocity). Note the non-MKS units.", units="m day-1", & + "velocity). Note the non-MKS units.", units="m day-1", scale=US%m_to_Z*US%T_to_s/86400.0, & 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.", & @@ -1130,8 +1130,6 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, restore_salt, "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 "//& @@ -1169,7 +1167,7 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, restore_salt, call get_param(param_file, mdl, "FLUXCONST", CS%Flux_const, & "The constant that relates the restoring surface fluxes "//& "to the relative surface anomalies (akin to a piston "//& - "velocity). Note the non-MKS units.", units="m day-1", & + "velocity). Note the non-MKS units.", units="m day-1", scale=US%m_to_Z*US%T_to_s/86400.0, & 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.", & @@ -1178,8 +1176,6 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, restore_salt, "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.", & diff --git a/config_src/solo_driver/MESO_surface_forcing.F90 b/config_src/solo_driver/MESO_surface_forcing.F90 index 0e9bce9676..0faaadf20e 100644 --- a/config_src/solo_driver/MESO_surface_forcing.F90 +++ b/config_src/solo_driver/MESO_surface_forcing.F90 @@ -174,7 +174,7 @@ subroutine MESO_buoyancy_forcing(sfc_state, fluxes, day, dt, G, US, CS) ! Set Temp_restore and Salin_restore to the temperature (in degC) and ! salinity (in ppt or PSU) that are being restored toward. if (G%mask2dT(i,j) > 0) then - fluxes%heat_added(i,j) = G%mask2dT(i,j) * US%QRZ_T_to_W_m2 * & + fluxes%heat_added(i,j) = G%mask2dT(i,j) * & ((CS%T_Restore(i,j) - sfc_state%SST(i,j)) * rhoXcp * CS%Flux_const) fluxes%vprec(i,j) = - (CS%Rho0 * CS%Flux_const) * & (CS%S_Restore(i,j) - sfc_state%SSS(i,j)) / & diff --git a/config_src/solo_driver/MOM_surface_forcing.F90 b/config_src/solo_driver/MOM_surface_forcing.F90 index b8edfc9526..5632dd7794 100644 --- a/config_src/solo_driver/MOM_surface_forcing.F90 +++ b/config_src/solo_driver/MOM_surface_forcing.F90 @@ -988,7 +988,7 @@ subroutine buoyancy_forcing_from_files(sfc_state, fluxes, day, dt, G, US, CS) if (CS%use_temperature) then do j=js,je ; do i=is,ie if (G%mask2dT(i,j) > 0) then - fluxes%heat_added(i,j) = G%mask2dT(i,j) * US%QRZ_T_to_W_m2 * & + fluxes%heat_added(i,j) = G%mask2dT(i,j) * & ((CS%T_Restore(i,j) - sfc_state%SST(i,j)) * rhoXcp * CS%Flux_const_T) fluxes%vprec(i,j) = - (CS%Rho0*CS%Flux_const_S) * & (CS%S_Restore(i,j) - sfc_state%SSS(i,j)) / & @@ -1143,7 +1143,7 @@ subroutine buoyancy_forcing_from_data_override(sfc_state, fluxes, day, dt, G, US if (CS%use_temperature) then do j=js,je ; do i=is,ie if (G%mask2dT(i,j) > 0) then - fluxes%heat_added(i,j) = G%mask2dT(i,j) * US%QRZ_T_to_W_m2 * & + fluxes%heat_added(i,j) = G%mask2dT(i,j) * & ((CS%T_Restore(i,j) - sfc_state%SST(i,j)) * rhoXcp * CS%Flux_const_T) fluxes%vprec(i,j) = - (CS%Rho0*CS%Flux_const_S) * & (CS%S_Restore(i,j) - sfc_state%SSS(i,j)) / & @@ -1341,14 +1341,14 @@ subroutine buoyancy_forcing_linear(sfc_state, fluxes, day, dt, G, US, CS) T_restore = CS%T_south + (CS%T_north-CS%T_south)*y S_restore = CS%S_south + (CS%S_north-CS%S_south)*y if (G%mask2dT(i,j) > 0) then - fluxes%heat_added(i,j) = G%mask2dT(i,j) * (US%QRZ_T_to_W_m2) * & + fluxes%heat_added(i,j) = G%mask2dT(i,j) * & ((T_Restore - sfc_state%SST(i,j)) * ((CS%Rho0 * fluxes%C_p) * CS%Flux_const)) fluxes%vprec(i,j) = - (CS%Rho0*CS%Flux_const) * & (S_Restore - sfc_state%SSS(i,j)) / & (0.5*(sfc_state%SSS(i,j) + S_Restore)) else fluxes%heat_added(i,j) = 0.0 - fluxes%vprec(i,j) = 0.0 + fluxes%vprec(i,j) = 0.0 endif enddo ; enddo else diff --git a/config_src/solo_driver/user_surface_forcing.F90 b/config_src/solo_driver/user_surface_forcing.F90 index a7a04d292a..47d474b35d 100644 --- a/config_src/solo_driver/user_surface_forcing.F90 +++ b/config_src/solo_driver/user_surface_forcing.F90 @@ -207,7 +207,7 @@ subroutine USER_buoyancy_forcing(sfc_state, fluxes, day, dt, G, US, CS) Temp_restore = 0.0 Salin_restore = 0.0 - fluxes%heat_added(i,j) = (G%mask2dT(i,j) * (rhoXcp * US%QRZ_T_to_W_m2*CS%Flux_const)) * & + fluxes%heat_added(i,j) = (G%mask2dT(i,j) * (rhoXcp * CS%Flux_const)) * & (Temp_restore - sfc_state%SST(i,j)) 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)))) diff --git a/src/core/MOM_forcing_type.F90 b/src/core/MOM_forcing_type.F90 index 5d28e36261..5062d11825 100644 --- a/src/core/MOM_forcing_type.F90 +++ b/src/core/MOM_forcing_type.F90 @@ -73,7 +73,7 @@ module MOM_forcing_type latent => NULL(), & !< latent [W m-2] (typically < 0) sens => NULL(), & !< sensible [W m-2] (typically negative) seaice_melt_heat => NULL(), & !< sea ice and snow melt or formation [W m-2] (typically negative) - heat_added => NULL() !< additional heat flux from SST restoring or flux adjustments [W m-2] + heat_added => NULL() !< additional heat flux from SST restoring or flux adjustments [Q R Z T-1 ~> W m-2] ! components of latent heat fluxes used for diagnostic purposes real, pointer, dimension(:,:) :: & @@ -415,6 +415,7 @@ subroutine extractFluxes1d(G, GV, US, fluxes, optics, nsw, j, dt_in_T, & ! or 0 for no limiting [H-1 ~> m-1 or m2 kg-1] real :: scale ! scale scales away fluxes if depth < FluxRescaleDepth real :: W_m2_to_H_T ! converts W/m^2 to H degC T-1 [degC H T-1 W-2 m2 ~> degC m3 J-1 or degC kg J-1] + real :: QRZ_to_H ! Converts heat in Q R Z to H degC [degC H Q-1 R-1 Z-1 ~> degC m3 J-1 or degC kg J-1] real :: RZ_T_to_W_m2_degC ! Converts mass fluxes to heat fluxes per degree temperature ! change [W m-2 degC-1 T R-1 Z-1 ~> J kg degC] real :: I_Cp ! 1.0 / C_p [kg decC J-1] @@ -445,6 +446,7 @@ subroutine extractFluxes1d(G, GV, US, fluxes, optics, nsw, j, dt_in_T, & RZ_T_to_W_m2_degC = US%QRZ_T_to_W_m2*fluxes%C_p I_Cp = 1.0 / (US%Q_to_J_kg*fluxes%C_p) W_m2_to_H_T = 1.0 / (US%s_to_T * GV%H_to_kg_m2 * US%Q_to_J_kg * fluxes%C_p) + QRZ_to_H = US%R_to_kg_m3 * US%Z_to_m * (1.0 / (GV%H_to_kg_m2 *fluxes%C_p)) RZcP_to_H = 1.0 / (GV%H_to_RZ * US%Q_to_J_kg*fluxes%C_p) @@ -599,8 +601,8 @@ subroutine extractFluxes1d(G, GV, US, fluxes, optics, nsw, j, dt_in_T, & ! Add heat flux from surface damping (restoring) (K * H) or flux adjustments. if (associated(fluxes%heat_added)) then - net_heat(i) = net_heat(i) + (scale * (dt_in_T * W_m2_to_H_T)) * fluxes%heat_added(i,j) - if (do_NHR) net_heat_rate(i) = net_heat_rate(i) + (scale * (W_m2_to_H_T)) * fluxes%heat_added(i,j) + net_heat(i) = net_heat(i) + (scale * (dt_in_T * QRZ_to_H)) * fluxes%heat_added(i,j) + if (do_NHR) net_heat_rate(i) = net_heat_rate(i) + (scale * QRZ_to_H) * fluxes%heat_added(i,j) endif ! Add explicit heat flux for runoff (which is part of the ice-ocean boundary @@ -1591,7 +1593,7 @@ subroutine register_forcing_type_diags(Time, diag, US, use_temperature, handles, cmor_long_name='Heat flux into ocean from snow and sea ice melt') handles%id_heat_added = register_diag_field('ocean_model', 'heat_added', diag%axesT1, Time, & - 'Flux Adjustment or restoring surface heat flux into ocean', 'W m-2') + 'Flux Adjustment or restoring surface heat flux into ocean', 'W m-2', conversion=US%QRZ_T_to_W_m2) !=============================================================== @@ -2556,7 +2558,7 @@ subroutine forcing_diagnostics(fluxes, sfc_state, G, US, time_end, diag, handles if (associated(fluxes%heat_content_massout)) & res(i,j) = res(i,j) + RZ_T_conversion*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) + US%QRZ_T_to_W_m2*fluxes%heat_added(i,j) enddo ; enddo if (handles%id_net_heat_surface > 0) call post_data(handles%id_net_heat_surface, res, diag) @@ -2735,7 +2737,7 @@ subroutine forcing_diagnostics(fluxes, sfc_state, G, US, time_end, diag, handles endif if ((handles%id_total_heat_added > 0) .and. associated(fluxes%heat_added)) then - total_transport = global_area_integral(fluxes%heat_added,G) + total_transport = global_area_integral(fluxes%heat_added, G, scale=US%QRZ_T_to_W_m2) call post_data(handles%id_total_heat_added, total_transport, diag) endif diff --git a/src/diagnostics/MOM_sum_output.F90 b/src/diagnostics/MOM_sum_output.F90 index 757351f467..0479e5f798 100644 --- a/src/diagnostics/MOM_sum_output.F90 +++ b/src/diagnostics/MOM_sum_output.F90 @@ -1041,7 +1041,7 @@ subroutine accumulate_net_input(fluxes, sfc_state, tv, dt, G, US, CS) heat_in(i,j) = heat_in(i,j) + US%L_to_m**2*G%areaT(i,j) * tv%frazil(i,j) enddo ; enddo ; endif if (associated(fluxes%heat_added)) then ; do j=js,je ; do i=is,ie - heat_in(i,j) = heat_in(i,j) + dt*US%T_to_s*US%L_to_m**2*G%areaT(i,j)*fluxes%heat_added(i,j) + heat_in(i,j) = heat_in(i,j) + RZL2_to_kg*US%Q_to_J_kg * 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 ! heat_in(i,j) = heat_in(i,j) - US%L_to_m**2*G%areaT(i,j) * sfc_state%sw_lost(i,j) diff --git a/src/user/BFB_surface_forcing.F90 b/src/user/BFB_surface_forcing.F90 index 4166b16418..f3c0ad734b 100644 --- a/src/user/BFB_surface_forcing.F90 +++ b/src/user/BFB_surface_forcing.F90 @@ -67,7 +67,7 @@ subroutine BFB_buoyancy_forcing(state, fluxes, day, dt, G, US, CS) real :: density_restore ! The potential density that is being restored ! toward [R ~> kg m-3]. real :: rhoXcp ! Reference density times heat capacity times unit scaling - ! factors [J T s-1 Z-1 m-2 degC-1 ~> J m-3 degC-1] + ! factors [Q R degC-1 ~> J m-3 degC-1] real :: buoy_rest_const ! A constant relating density anomalies to the ! restoring buoyancy flux [L2 T-3 R-1 ~> m5 s-3 kg-1]. integer :: i, j, is, ie, js, je @@ -128,7 +128,7 @@ subroutine BFB_buoyancy_forcing(state, fluxes, day, dt, G, US, CS) call MOM_error(FATAL, "User_buoyancy_surface_forcing: " // & "Temperature and salinity restoring used without modification." ) - rhoXcp = US%R_to_kg_m3*US%Z_to_m*US%s_to_T * CS%Rho0 * US%Q_to_J_kg*fluxes%C_p + rhoXcp = CS%Rho0 * fluxes%C_p do j=js,je ; do i=is,ie ! Set Temp_restore and Salin_restore to the temperature (in degC) and ! salinity (in ppt) that are being restored toward. From ad36df79704e1882b73fa18ee558b40f7fab09c4 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 13 Feb 2020 21:25:23 -0500 Subject: [PATCH 066/316] +Rescaled units of fluxes%lw and fluxes%latent Rescaled the units of fluxes%lw and fluxes%latent to [Q R Z T-1] for dimensional consistency testing. All answers are bitwise identical. --- .../MOM_surface_forcing_gfdl.F90 | 11 +++-- .../ice_solo_driver/MOM_surface_forcing.F90 | 8 ++-- .../ice_solo_driver/user_surface_forcing.F90 | 2 +- .../mct_driver/mom_surface_forcing_mct.F90 | 11 +++-- .../mom_surface_forcing_nuopc.F90 | 11 +++-- .../solo_driver/MESO_surface_forcing.F90 | 2 +- .../solo_driver/MOM_surface_forcing.F90 | 27 ++++++------ .../solo_driver/user_surface_forcing.F90 | 2 +- src/core/MOM_forcing_type.F90 | 42 +++++++++---------- src/diagnostics/MOM_sum_output.F90 | 2 +- src/user/BFB_surface_forcing.F90 | 2 +- src/user/dumbbell_surface_forcing.F90 | 2 +- 12 files changed, 67 insertions(+), 55 deletions(-) diff --git a/config_src/coupled_driver/MOM_surface_forcing_gfdl.F90 b/config_src/coupled_driver/MOM_surface_forcing_gfdl.F90 index 81082fbfd5..1eeb0b8dd5 100644 --- a/config_src/coupled_driver/MOM_surface_forcing_gfdl.F90 +++ b/config_src/coupled_driver/MOM_surface_forcing_gfdl.F90 @@ -482,7 +482,7 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, endif if (associated(IOB%lw_flux)) then - fluxes%LW(i,j) = IOB%lw_flux(i-i0,j-j0) * G%mask2dT(i,j) + fluxes%LW(i,j) = US%W_m2_to_QRZ_T * IOB%lw_flux(i-i0,j-j0) * G%mask2dT(i,j) if (CS%check_no_land_fluxes) & call check_mask_val_consistency(IOB%lw_flux(i-i0,j-j0), G%mask2dT(i,j), i, j, 'lw_flux', G) endif @@ -495,15 +495,18 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, fluxes%latent(i,j) = 0.0 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(i,j) = fluxes%latent(i,j) - & + IOB%fprec(i-i0,j-j0)*US%W_m2_to_QRZ_T*CS%latent_heat_fusion fluxes%latent_fprec_diag(i,j) = -G%mask2dT(i,j) * IOB%fprec(i-i0,j-j0)*CS%latent_heat_fusion endif 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(i,j) = fluxes%latent(i,j) - & + IOB%calving(i-i0,j-j0)*US%W_m2_to_QRZ_T*CS%latent_heat_fusion fluxes%latent_frunoff_diag(i,j) = -G%mask2dT(i,j) * IOB%calving(i-i0,j-j0)*CS%latent_heat_fusion endif if (associated(IOB%q_flux)) then - fluxes%latent(i,j) = fluxes%latent(i,j) - IOB%q_flux(i-i0,j-j0)*CS%latent_heat_vapor + fluxes%latent(i,j) = fluxes%latent(i,j) - & + IOB%q_flux(i-i0,j-j0)*US%W_m2_to_QRZ_T*CS%latent_heat_vapor fluxes%latent_evap_diag(i,j) = -G%mask2dT(i,j) * IOB%q_flux(i-i0,j-j0)*CS%latent_heat_vapor endif diff --git a/config_src/ice_solo_driver/MOM_surface_forcing.F90 b/config_src/ice_solo_driver/MOM_surface_forcing.F90 index 1cc638f8f7..d31c2d9d70 100644 --- a/config_src/ice_solo_driver/MOM_surface_forcing.F90 +++ b/config_src/ice_solo_driver/MOM_surface_forcing.F90 @@ -662,17 +662,17 @@ subroutine buoyancy_forcing_from_files(sfc_state, fluxes, day, dt, G, US, CS) call MOM_read_data(trim(CS%inputdir)//trim(CS%longwavedown_file), "lwdn_sfc", & - fluxes%LW(:,:), G%Domain, timelevel=time_lev) + fluxes%LW(:,:), G%Domain, timelevel=time_lev, scale=US%W_m2_to_QRZ_T) call MOM_read_data(trim(CS%inputdir)//trim(CS%longwaveup_file), "lwup_sfc", & - temp(:,:), G%Domain, timelevel=time_lev) + temp(:,:), G%Domain, timelevel=time_lev, scale=US%W_m2_to_QRZ_T) do j=js,je ; do i=is,ie ; fluxes%LW(i,j) = fluxes%LW(i,j) - temp(i,j) ; enddo ; enddo call MOM_read_data(trim(CS%inputdir)//trim(CS%evaporation_file), "evap", & temp(:,:), G%Domain, timelevel=time_lev) do j=js,je ; do i=is,ie - fluxes%latent(i,j) = -hlv*temp(i,j) + fluxes%latent(i,j) = -US%W_m2_to_QRZ_T*hlv*temp(i,j) fluxes%evap(i,j) = -US%kg_m3_to_R*US%m_to_Z*US%T_to_s * temp(i,j) - fluxes%latent_evap_diag(i,j) = fluxes%latent(i,j) + fluxes%latent_evap_diag(i,j) = US%QRZ_T_to_W_m2*fluxes%latent(i,j) enddo ; enddo diff --git a/config_src/ice_solo_driver/user_surface_forcing.F90 b/config_src/ice_solo_driver/user_surface_forcing.F90 index b8f26c512c..10417d4a1e 100644 --- a/config_src/ice_solo_driver/user_surface_forcing.F90 +++ b/config_src/ice_solo_driver/user_surface_forcing.F90 @@ -227,7 +227,7 @@ subroutine USER_buoyancy_forcing(sfc_state, fluxes, day, dt, G, US, CS) ! 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. + ! Heat fluxes are in units of [Q R Z T-1 ~> W m-2] and are positive into the ocean. fluxes%lw(i,j) = 0.0 * G%mask2dT(i,j) fluxes%latent(i,j) = 0.0 * G%mask2dT(i,j) fluxes%sens(i,j) = 0.0 * G%mask2dT(i,j) diff --git a/config_src/mct_driver/mom_surface_forcing_mct.F90 b/config_src/mct_driver/mom_surface_forcing_mct.F90 index 538faad4de..0d7a8af13c 100644 --- a/config_src/mct_driver/mom_surface_forcing_mct.F90 +++ b/config_src/mct_driver/mom_surface_forcing_mct.F90 @@ -468,7 +468,7 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, ! longwave radiation, sum up and down (W/m2) if (associated(IOB%lw_flux)) & - fluxes%LW(i,j) = IOB%lw_flux(i-i0,j-j0) * G%mask2dT(i,j) + fluxes%lw(i,j) = US%W_m2_to_QRZ_T * IOB%lw_flux(i-i0,j-j0) * G%mask2dT(i,j) ! sensible heat flux (W/m2) if (associated(IOB%t_flux)) & @@ -486,17 +486,20 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, fluxes%latent(i,j) = 0.0 ! contribution from frozen ppt 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(i,j) = fluxes%latent(i,j) + & + IOB%fprec(i-i0,j-j0)*US%W_m2_to_QRZ_T*CS%latent_heat_fusion fluxes%latent_fprec_diag(i,j) = G%mask2dT(i,j) * IOB%fprec(i-i0,j-j0)*CS%latent_heat_fusion endif ! contribution from frozen runoff if (associated(fluxes%frunoff)) then - fluxes%latent(i,j) = fluxes%latent(i,j) + IOB%rofi_flux(i-i0,j-j0)*CS%latent_heat_fusion + fluxes%latent(i,j) = fluxes%latent(i,j) + & + IOB%rofi_flux(i-i0,j-j0)*US%W_m2_to_QRZ_T*CS%latent_heat_fusion fluxes%latent_frunoff_diag(i,j) = G%mask2dT(i,j) * IOB%rofi_flux(i-i0,j-j0)*CS%latent_heat_fusion endif ! contribution from evaporation 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(i,j) = fluxes%latent(i,j) + & + IOB%q_flux(i-i0,j-j0)*US%W_m2_to_QRZ_T*CS%latent_heat_vapor fluxes%latent_evap_diag(i,j) = G%mask2dT(i,j) * IOB%q_flux(i-i0,j-j0)*CS%latent_heat_vapor endif fluxes%latent(i,j) = G%mask2dT(i,j) * fluxes%latent(i,j) diff --git a/config_src/nuopc_driver/mom_surface_forcing_nuopc.F90 b/config_src/nuopc_driver/mom_surface_forcing_nuopc.F90 index 6446eca424..3b895b19cc 100644 --- a/config_src/nuopc_driver/mom_surface_forcing_nuopc.F90 +++ b/config_src/nuopc_driver/mom_surface_forcing_nuopc.F90 @@ -465,7 +465,7 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, fluxes%heat_content_frunoff(i,j) = kg_m2_s_conversion*IOB%calving_hflx(i-i0,j-j0) * G%mask2dT(i,j) if (associated(IOB%lw_flux)) & - fluxes%LW(i,j) = IOB%lw_flux(i-i0,j-j0) * G%mask2dT(i,j) + fluxes%lw(i,j) = US%W_m2_to_QRZ_T * IOB%lw_flux(i-i0,j-j0) * G%mask2dT(i,j) if (associated(IOB%t_flux)) & fluxes%sens(i,j) = IOB%t_flux(i-i0,j-j0) * G%mask2dT(i,j) @@ -480,15 +480,18 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, fluxes%latent(i,j) = 0.0 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(i,j) = fluxes%latent(i,j) + & + IOB%fprec(i-i0,j-j0)*US%W_m2_to_QRZ_T*CS%latent_heat_fusion fluxes%latent_fprec_diag(i,j) = G%mask2dT(i,j) * IOB%fprec(i-i0,j-j0)*CS%latent_heat_fusion endif 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(i,j) = fluxes%latent(i,j) + & + IOB%calving(i-i0,j-j0)*US%W_m2_to_QRZ_T*CS%latent_heat_fusion fluxes%latent_frunoff_diag(i,j) = G%mask2dT(i,j) * IOB%calving(i-i0,j-j0)*CS%latent_heat_fusion endif if (associated(IOB%q_flux)) then - fluxes%latent(i,j) = fluxes%latent(i,j) + IOB%q_flux(i-i0,j-j0)*CS%latent_heat_vapor + fluxes%latent(i,j) = fluxes%latent(i,j) + & + IOB%q_flux(i-i0,j-j0)*US%W_m2_to_QRZ_T*CS%latent_heat_vapor fluxes%latent_evap_diag(i,j) = G%mask2dT(i,j) * IOB%q_flux(i-i0,j-j0)*CS%latent_heat_vapor endif fluxes%latent(i,j) = G%mask2dT(i,j) * fluxes%latent(i,j) diff --git a/config_src/solo_driver/MESO_surface_forcing.F90 b/config_src/solo_driver/MESO_surface_forcing.F90 index 0faaadf20e..77303d4779 100644 --- a/config_src/solo_driver/MESO_surface_forcing.F90 +++ b/config_src/solo_driver/MESO_surface_forcing.F90 @@ -147,7 +147,7 @@ subroutine MESO_buoyancy_forcing(sfc_state, fluxes, day, dt, G, US, CS) ! 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. + ! Heat fluxes are in units of [Q R Z T-1 ~> W m-2] and are positive into the ocean. fluxes%lw(i,j) = 0.0 * G%mask2dT(i,j) fluxes%latent(i,j) = 0.0 * G%mask2dT(i,j) fluxes%sens(i,j) = CS%Heat(i,j) * G%mask2dT(i,j) diff --git a/config_src/solo_driver/MOM_surface_forcing.F90 b/config_src/solo_driver/MOM_surface_forcing.F90 index 470859c310..a978aa02c9 100644 --- a/config_src/solo_driver/MOM_surface_forcing.F90 +++ b/config_src/solo_driver/MOM_surface_forcing.F90 @@ -820,11 +820,11 @@ subroutine buoyancy_forcing_from_files(sfc_state, fluxes, day, dt, G, US, CS) case (365) ; time_lev = time_lev_daily case default ; time_lev = 1 end select - call MOM_read_data(CS%longwave_file, CS%LW_var, fluxes%LW(:,:), & - G%Domain, timelevel=time_lev) + call MOM_read_data(CS%longwave_file, CS%LW_var, fluxes%lw(:,:), & + G%Domain, timelevel=time_lev, scale=US%W_m2_to_QRZ_T) if (CS%archaic_OMIP_file) then call MOM_read_data(CS%longwaveup_file, "lwup_sfc", temp(:,:), G%Domain, & - timelevel=time_lev) + timelevel=time_lev, scale=US%W_m2_to_QRZ_T) do j=js,je ; do i=is,ie ; fluxes%LW(i,j) = fluxes%LW(i,j) - temp(i,j) ; enddo ; enddo endif CS%LW_last_lev = time_lev @@ -839,9 +839,9 @@ subroutine buoyancy_forcing_from_files(sfc_state, fluxes, day, dt, G, US, CS) call MOM_read_data(CS%evaporation_file, CS%evap_var, temp(:,:), & G%Domain, timelevel=time_lev) do j=js,je ; do i=is,ie - fluxes%latent(i,j) = -CS%latent_heat_vapor*temp(i,j) + fluxes%latent(i,j) = -US%W_m2_to_QRZ_T*CS%latent_heat_vapor*temp(i,j) fluxes%evap(i,j) = -kg_m2_s_conversion*temp(i,j) - fluxes%latent_evap_diag(i,j) = fluxes%latent(i,j) + fluxes%latent_evap_diag(i,j) = US%QRZ_T_to_W_m2*fluxes%latent(i,j) enddo ; enddo else call MOM_read_data(CS%evaporation_file, CS%evap_var, fluxes%evap(:,:), & @@ -856,9 +856,9 @@ subroutine buoyancy_forcing_from_files(sfc_state, fluxes, day, dt, G, US, CS) end select if (.not.CS%archaic_OMIP_file) then call MOM_read_data(CS%latentheat_file, CS%latent_var, fluxes%latent(:,:), & - G%Domain, timelevel=time_lev) + G%Domain, timelevel=time_lev, scale=US%W_m2_to_QRZ_T) do j=js,je ; do i=is,ie - fluxes%latent_evap_diag(i,j) = fluxes%latent(i,j) + fluxes%latent_evap_diag(i,j) = US%QRZ_T_to_W_m2*fluxes%latent(i,j) enddo ; enddo endif CS%latent_last_lev = time_lev @@ -968,7 +968,7 @@ subroutine buoyancy_forcing_from_files(sfc_state, fluxes, day, dt, G, US, CS) fluxes%fprec(i,j) = fluxes%fprec(i,j) * G%mask2dT(i,j) fluxes%lrunoff(i,j) = fluxes%lrunoff(i,j) * G%mask2dT(i,j) fluxes%frunoff(i,j) = fluxes%frunoff(i,j) * G%mask2dT(i,j) - fluxes%LW(i,j) = fluxes%LW(i,j) * G%mask2dT(i,j) + fluxes%lw(i,j) = fluxes%lw(i,j) * G%mask2dT(i,j) fluxes%sens(i,j) = fluxes%sens(i,j) * G%mask2dT(i,j) fluxes%sw(i,j) = fluxes%sw(i,j) * G%mask2dT(i,j) fluxes%latent(i,j) = fluxes%latent(i,j) * G%mask2dT(i,j) @@ -1081,8 +1081,11 @@ subroutine buoyancy_forcing_from_data_override(sfc_state, fluxes, day, dt, G, US js_in = G%jsc - G%jsd + 1 je_in = G%jec - G%jsd + 1 - call data_override('OCN', 'lw', fluxes%LW(:,:), day, & + call data_override('OCN', 'lw', fluxes%lw(:,:), day, & is_in=is_in, ie_in=ie_in, js_in=js_in, je_in=je_in) + if (US%QRZ_T_to_W_m2 /= 1.0) then ; do j=js,je ; do i=is,ie + fluxes%lw(i,j) = fluxes%lw(i,j) * US%W_m2_to_QRZ_T + enddo ; enddo ; endif call data_override('OCN', 'evap', fluxes%evap(:,:), day, & is_in=is_in, ie_in=ie_in, js_in=js_in, je_in=je_in) @@ -1091,8 +1094,8 @@ subroutine buoyancy_forcing_from_data_override(sfc_state, fluxes, day, dt, G, US ! This is dangerous because it is not clear whether the data files have been read! fluxes%evap(i,j) = -fluxes%evap(i,j) ! Normal convention is positive into the ocean ! 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) + fluxes%latent(i,j) = US%W_m2_to_QRZ_T * CS%latent_heat_vapor*fluxes%evap(i,j) + fluxes%latent_evap_diag(i,j) = US%QRZ_T_to_W_m2*fluxes%latent(i,j) fluxes%evap(i,j) = kg_m2_s_conversion*fluxes%evap(i,j) enddo ; enddo @@ -1182,7 +1185,7 @@ subroutine buoyancy_forcing_from_data_override(sfc_state, fluxes, day, dt, G, US fluxes%fprec(i,j) = fluxes%fprec(i,j) * G%mask2dT(i,j) fluxes%lrunoff(i,j) = fluxes%lrunoff(i,j) * G%mask2dT(i,j) fluxes%frunoff(i,j) = fluxes%frunoff(i,j) * G%mask2dT(i,j) - fluxes%LW(i,j) = fluxes%LW(i,j) * G%mask2dT(i,j) + fluxes%lw(i,j) = fluxes%lw(i,j) * G%mask2dT(i,j) fluxes%latent(i,j) = fluxes%latent(i,j) * G%mask2dT(i,j) fluxes%sens(i,j) = fluxes%sens(i,j) * G%mask2dT(i,j) fluxes%sw(i,j) = fluxes%sw(i,j) * G%mask2dT(i,j) diff --git a/config_src/solo_driver/user_surface_forcing.F90 b/config_src/solo_driver/user_surface_forcing.F90 index 47d474b35d..97da89e69e 100644 --- a/config_src/solo_driver/user_surface_forcing.F90 +++ b/config_src/solo_driver/user_surface_forcing.F90 @@ -178,7 +178,7 @@ subroutine USER_buoyancy_forcing(sfc_state, fluxes, day, dt, G, US, CS) ! 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. + ! Heat fluxes are in units of [Q R Z T-1 ~> W m-2] and are positive into the ocean. fluxes%lw(i,j) = 0.0 * G%mask2dT(i,j) fluxes%latent(i,j) = 0.0 * G%mask2dT(i,j) fluxes%sens(i,j) = 0.0 * G%mask2dT(i,j) diff --git a/src/core/MOM_forcing_type.F90 b/src/core/MOM_forcing_type.F90 index 5062d11825..c6b591b082 100644 --- a/src/core/MOM_forcing_type.F90 +++ b/src/core/MOM_forcing_type.F90 @@ -66,11 +66,11 @@ module MOM_forcing_type sw_vis_dif => NULL(), & !< visible, diffuse shortwave [W m-2] sw_nir_dir => NULL(), & !< near-IR, direct shortwave [W m-2] sw_nir_dif => NULL(), & !< near-IR, diffuse shortwave [W m-2] - lw => NULL() !< longwave [W m-2] (typically negative) + lw => NULL() !< longwave [Q R Z T-1 ~> W m-2] (typically negative) ! turbulent heat fluxes into the ocean [W m-2] real, pointer, dimension(:,:) :: & - latent => NULL(), & !< latent [W m-2] (typically < 0) + latent => NULL(), & !< latent [Q R Z T-1 ~> W m-2] (typically < 0) sens => NULL(), & !< sensible [W m-2] (typically negative) seaice_melt_heat => NULL(), & !< sea ice and snow melt or formation [W m-2] (typically negative) heat_added => NULL() !< additional heat flux from SST restoring or flux adjustments [Q R Z T-1 ~> W m-2] @@ -585,18 +585,18 @@ subroutine extractFluxes1d(G, GV, US, fluxes, optics, nsw, j, dt_in_T, & ! CIME provides heat flux from snow&ice melt (seaice_melt_heat), so this is added below if (associated(fluxes%seaice_melt_heat)) then net_heat(i) = scale * dt_in_T * W_m2_to_H_T * & - ( fluxes%sw(i,j) + ((fluxes%lw(i,j) + fluxes%latent(i,j)) + fluxes%sens(i,j) + & + ( fluxes%sw(i,j) + (US%QRZ_T_to_W_m2*(fluxes%lw(i,j) + fluxes%latent(i,j)) + fluxes%sens(i,j) + & fluxes%seaice_melt_heat(i,j)) ) !Repeats above code w/ dt=1. for legacy reason if (do_NHR) net_heat_rate(i) = scale * W_m2_to_H_T * & - ( fluxes%sw(i,j) + ((fluxes%lw(i,j) + fluxes%latent(i,j)) + fluxes%sens(i,j) + & + ( fluxes%sw(i,j) + (US%QRZ_T_to_W_m2*(fluxes%lw(i,j) + fluxes%latent(i,j)) + fluxes%sens(i,j) + & fluxes%seaice_melt_heat(i,j))) else net_heat(i) = scale * dt_in_T * W_m2_to_H_T * & - ( fluxes%sw(i,j) + ((fluxes%lw(i,j) + fluxes%latent(i,j)) + fluxes%sens(i,j)) ) + ( fluxes%sw(i,j) + (US%QRZ_T_to_W_m2*(fluxes%lw(i,j) + fluxes%latent(i,j)) + fluxes%sens(i,j)) ) !Repeats above code w/ dt=1. for legacy reason if (do_NHR) net_heat_rate(i) = scale * W_m2_to_H_T * & - ( fluxes%sw(i,j) + ((fluxes%lw(i,j) + fluxes%latent(i,j)) + fluxes%sens(i,j)) ) + ( fluxes%sw(i,j) + (US%QRZ_T_to_W_m2*(fluxes%lw(i,j) + fluxes%latent(i,j)) + fluxes%sens(i,j)) ) endif ! Add heat flux from surface damping (restoring) (K * H) or flux adjustments. @@ -1043,9 +1043,9 @@ subroutine MOM_forcing_chksum(mesg, fluxes, G, US, haloshift) if (associated(fluxes%sw_nir_dif)) & call hchksum(fluxes%sw_nir_dif, mesg//" fluxes%sw_nir_dif",G%HI,haloshift=hshift) if (associated(fluxes%lw)) & - call hchksum(fluxes%lw, mesg//" fluxes%lw",G%HI,haloshift=hshift) + call hchksum(fluxes%lw, mesg//" fluxes%lw", G%HI, haloshift=hshift, scale=US%QRZ_T_to_W_m2) if (associated(fluxes%latent)) & - call hchksum(fluxes%latent, mesg//" fluxes%latent",G%HI,haloshift=hshift) + call hchksum(fluxes%latent, mesg//" fluxes%latent", G%HI, haloshift=hshift, scale=US%QRZ_T_to_W_m2) if (associated(fluxes%latent_evap_diag)) & call hchksum(fluxes%latent_evap_diag, mesg//" fluxes%latent_evap_diag",G%HI,haloshift=hshift) if (associated(fluxes%latent_fprec_diag)) & @@ -1551,7 +1551,7 @@ subroutine register_forcing_type_diags(Time, diag, US, use_temperature, handles, 'Combined longwave, latent, and sensible heating at ocean surface', 'W m-2') handles%id_lw = register_diag_field('ocean_model', 'LW', diag%axesT1, Time, & - 'Longwave radiation flux into ocean', 'W m-2', & + 'Longwave radiation flux into ocean', 'W m-2', conversion=US%QRZ_T_to_W_m2, & standard_name='surface_net_downward_longwave_flux', & cmor_field_name='rlntds', & cmor_standard_name='surface_net_downward_longwave_flux', & @@ -1559,7 +1559,7 @@ subroutine register_forcing_type_diags(Time, diag, US, use_temperature, handles, handles%id_lat = register_diag_field('ocean_model', 'latent', diag%axesT1, Time, & 'Latent heat flux into ocean due to fusion and evaporation (negative means ocean heat loss)', & - 'W m-2', cmor_field_name='hflso', & + 'W m-2', conversion=US%QRZ_T_to_W_m2, cmor_field_name='hflso', & cmor_standard_name='surface_downward_latent_heat_flux', & cmor_long_name='Surface Downward Latent Heat Flux due to Evap + Melt Snow/Ice') @@ -2511,8 +2511,8 @@ subroutine forcing_diagnostics(fluxes, sfc_state, G, US, time_end, diag, handles 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%LW)) res(i,j) = res(i,j) + US%QRZ_T_to_W_m2*fluxes%lw(i,j) + if (associated(fluxes%latent)) res(i,j) = res(i,j) + US%QRZ_T_to_W_m2*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%seaice_melt_heat)) res(i,j) = res(i,j) + fluxes%seaice_melt_heat(i,j) @@ -2532,8 +2532,8 @@ subroutine forcing_diagnostics(fluxes, sfc_state, G, US, time_end, diag, handles 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%LW)) res(i,j) = res(i,j) + US%QRZ_T_to_W_m2*fluxes%lw(i,j) + if (associated(fluxes%latent)) res(i,j) = res(i,j) + US%QRZ_T_to_W_m2*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%seaice_melt_heat)) res(i,j) = res(i,j) + fluxes%seaice_melt_heat(i,j) @@ -2619,7 +2619,7 @@ subroutine forcing_diagnostics(fluxes, sfc_state, G, US, time_end, diag, handles 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) + res(i,j) = US%QRZ_T_to_W_m2*(fluxes%lw(i,j) + fluxes%latent(i,j)) + fluxes%sens(i,j) enddo ; enddo call post_data(handles%id_LwLatSens, res, diag) endif @@ -2627,7 +2627,7 @@ subroutine forcing_diagnostics(fluxes, sfc_state, G, US, time_end, diag, handles 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) + res(i,j) = US%QRZ_T_to_W_m2*(fluxes%lw(i,j) + fluxes%latent(i,j)) + fluxes%sens(i,j) enddo ; enddo total_transport = global_area_integral(res,G) call post_data(handles%id_total_LwLatSens, total_transport, diag) @@ -2636,7 +2636,7 @@ subroutine forcing_diagnostics(fluxes, sfc_state, G, US, time_end, diag, handles 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) + res(i,j) = US%QRZ_T_to_W_m2*(fluxes%lw(i,j) + fluxes%latent(i,j)) + fluxes%sens(i,j) enddo ; enddo ave_flux = global_area_mean(res,G) call post_data(handles%id_LwLatSens_ga, ave_flux, diag) @@ -2666,11 +2666,11 @@ subroutine forcing_diagnostics(fluxes, sfc_state, G, US, time_end, diag, handles call post_data(handles%id_lw, fluxes%lw, diag) endif if ((handles%id_total_lw > 0) .and. associated(fluxes%lw)) then - total_transport = global_area_integral(fluxes%lw,G) + total_transport = global_area_integral(fluxes%lw, G, scale=US%QRZ_T_to_W_m2) call post_data(handles%id_total_lw, total_transport, diag) endif if ((handles%id_lw_ga > 0) .and. associated(fluxes%lw)) then - ave_flux = global_area_mean(fluxes%lw,G) + ave_flux = global_area_mean(fluxes%lw, G, scale=US%QRZ_T_to_W_m2) call post_data(handles%id_lw_ga, ave_flux, diag) endif @@ -2678,11 +2678,11 @@ subroutine forcing_diagnostics(fluxes, sfc_state, G, US, time_end, diag, handles call post_data(handles%id_lat, fluxes%latent, diag) endif if ((handles%id_total_lat > 0) .and. associated(fluxes%latent)) then - total_transport = global_area_integral(fluxes%latent,G) + total_transport = global_area_integral(fluxes%latent, G, scale=US%QRZ_T_to_W_m2) call post_data(handles%id_total_lat, total_transport, diag) endif if ((handles%id_lat_ga > 0) .and. associated(fluxes%latent)) then - ave_flux = global_area_mean(fluxes%latent,G) + ave_flux = global_area_mean(fluxes%latent, G, scale=US%QRZ_T_to_W_m2) call post_data(handles%id_lat_ga, ave_flux, diag) endif diff --git a/src/diagnostics/MOM_sum_output.F90 b/src/diagnostics/MOM_sum_output.F90 index 0479e5f798..54c30cb523 100644 --- a/src/diagnostics/MOM_sum_output.F90 +++ b/src/diagnostics/MOM_sum_output.F90 @@ -1001,7 +1001,7 @@ subroutine accumulate_net_input(fluxes, sfc_state, tv, dt, G, US, CS) if (associated(fluxes%sw)) then ; do j=js,je ; do i=is,ie heat_in(i,j) = heat_in(i,j) + dt*US%T_to_s*US%L_to_m**2*G%areaT(i,j) * (fluxes%sw(i,j) + & - (fluxes%lw(i,j) + (fluxes%latent(i,j) + fluxes%sens(i,j)))) + (US%QRZ_T_to_W_m2*fluxes%lw(i,j) + (US%QRZ_T_to_W_m2*fluxes%latent(i,j) + fluxes%sens(i,j)))) enddo ; enddo ; endif if (associated(fluxes%seaice_melt_heat)) then ; do j=js,je ; do i=is,ie diff --git a/src/user/BFB_surface_forcing.F90 b/src/user/BFB_surface_forcing.F90 index f3c0ad734b..ec7f907fd1 100644 --- a/src/user/BFB_surface_forcing.F90 +++ b/src/user/BFB_surface_forcing.F90 @@ -106,7 +106,7 @@ subroutine BFB_buoyancy_forcing(state, fluxes, day, dt, G, US, CS) ! 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. + ! Heat fluxes are in units of [Q R Z T-1 ~> W m-2] and are positive into the ocean. fluxes%lw(i,j) = 0.0 * G%mask2dT(i,j) fluxes%latent(i,j) = 0.0 * G%mask2dT(i,j) fluxes%sens(i,j) = 0.0 * G%mask2dT(i,j) diff --git a/src/user/dumbbell_surface_forcing.F90 b/src/user/dumbbell_surface_forcing.F90 index 2d19cce6dd..63f8009235 100644 --- a/src/user/dumbbell_surface_forcing.F90 +++ b/src/user/dumbbell_surface_forcing.F90 @@ -105,7 +105,7 @@ subroutine dumbbell_buoyancy_forcing(state, fluxes, day, dt, G, US, CS) ! 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. + ! Heat fluxes are in units of [Q R Z T-1 ~> W m-2] and are positive into the ocean. fluxes%lw(i,j) = 0.0 * G%mask2dT(i,j) fluxes%latent(i,j) = 0.0 * G%mask2dT(i,j) fluxes%sens(i,j) = 0.0 * G%mask2dT(i,j) From 7ecdddf7e4a6b327f4922a1a05f56c58ef642ec7 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 14 Feb 2020 08:56:18 -0500 Subject: [PATCH 067/316] +Rescaled units of fluxes%sens Rescaled the units of fluxes%sens and the diagnostics fluxes%latent_evap_diag, fluxes%latent_fprec_diag, fluxes%frunoff_diag and fluxes%seaice_melt_heat to [Q R Z T-1] for dimensional consistency testing. All answers are bitwise identical. --- .../MOM_surface_forcing_gfdl.F90 | 8 +-- .../ice_solo_driver/MOM_surface_forcing.F90 | 15 ++-- .../mct_driver/mom_surface_forcing_mct.F90 | 16 ++--- .../mom_surface_forcing_nuopc.F90 | 12 ++-- .../solo_driver/MESO_surface_forcing.F90 | 2 +- .../solo_driver/MOM_surface_forcing.F90 | 31 ++++---- src/core/MOM_forcing_type.F90 | 72 ++++++++++--------- src/diagnostics/MOM_sum_output.F90 | 5 +- src/ice_shelf/MOM_ice_shelf.F90 | 4 +- src/user/SCM_CVMix_tests.F90 | 22 +++--- 10 files changed, 97 insertions(+), 90 deletions(-) diff --git a/config_src/coupled_driver/MOM_surface_forcing_gfdl.F90 b/config_src/coupled_driver/MOM_surface_forcing_gfdl.F90 index 1eeb0b8dd5..ec5b53d79d 100644 --- a/config_src/coupled_driver/MOM_surface_forcing_gfdl.F90 +++ b/config_src/coupled_driver/MOM_surface_forcing_gfdl.F90 @@ -488,7 +488,7 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, endif if (associated(IOB%t_flux)) then - fluxes%sens(i,j) = - IOB%t_flux(i-i0,j-j0) * G%mask2dT(i,j) + fluxes%sens(i,j) = -US%W_m2_to_QRZ_T* IOB%t_flux(i-i0,j-j0) * G%mask2dT(i,j) if (CS%check_no_land_fluxes) & call check_mask_val_consistency(IOB%t_flux(i-i0,j-j0), G%mask2dT(i,j), i, j, 't_flux', G) endif @@ -497,17 +497,17 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, if (associated(IOB%fprec)) then fluxes%latent(i,j) = fluxes%latent(i,j) - & IOB%fprec(i-i0,j-j0)*US%W_m2_to_QRZ_T*CS%latent_heat_fusion - fluxes%latent_fprec_diag(i,j) = -G%mask2dT(i,j) * IOB%fprec(i-i0,j-j0)*CS%latent_heat_fusion + fluxes%latent_fprec_diag(i,j) = -G%mask2dT(i,j) * IOB%fprec(i-i0,j-j0)*US%W_m2_to_QRZ_T*CS%latent_heat_fusion endif if (associated(IOB%calving)) then fluxes%latent(i,j) = fluxes%latent(i,j) - & IOB%calving(i-i0,j-j0)*US%W_m2_to_QRZ_T*CS%latent_heat_fusion - fluxes%latent_frunoff_diag(i,j) = -G%mask2dT(i,j) * IOB%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)*US%W_m2_to_QRZ_T*CS%latent_heat_fusion endif if (associated(IOB%q_flux)) then fluxes%latent(i,j) = fluxes%latent(i,j) - & IOB%q_flux(i-i0,j-j0)*US%W_m2_to_QRZ_T*CS%latent_heat_vapor - fluxes%latent_evap_diag(i,j) = -G%mask2dT(i,j) * IOB%q_flux(i-i0,j-j0)*CS%latent_heat_vapor + fluxes%latent_evap_diag(i,j) = -G%mask2dT(i,j) * IOB%q_flux(i-i0,j-j0)*US%W_m2_to_QRZ_T*CS%latent_heat_vapor endif fluxes%latent(i,j) = G%mask2dT(i,j) * fluxes%latent(i,j) diff --git a/config_src/ice_solo_driver/MOM_surface_forcing.F90 b/config_src/ice_solo_driver/MOM_surface_forcing.F90 index d31c2d9d70..fd11a6f5a8 100644 --- a/config_src/ice_solo_driver/MOM_surface_forcing.F90 +++ b/config_src/ice_solo_driver/MOM_surface_forcing.F90 @@ -668,17 +668,14 @@ subroutine buoyancy_forcing_from_files(sfc_state, fluxes, day, dt, G, US, CS) do j=js,je ; do i=is,ie ; fluxes%LW(i,j) = fluxes%LW(i,j) - temp(i,j) ; enddo ; enddo call MOM_read_data(trim(CS%inputdir)//trim(CS%evaporation_file), "evap", & - temp(:,:), G%Domain, timelevel=time_lev) + fluxes%evap(:,:), G%Domain, timelevel=time_lev, scale=-US%kg_m3_to_R*US%m_to_Z*US%T_to_s) do j=js,je ; do i=is,ie - fluxes%latent(i,j) = -US%W_m2_to_QRZ_T*hlv*temp(i,j) - fluxes%evap(i,j) = -US%kg_m3_to_R*US%m_to_Z*US%T_to_s * temp(i,j) - fluxes%latent_evap_diag(i,j) = US%QRZ_T_to_W_m2*fluxes%latent(i,j) - + fluxes%latent(i,j) = US%J_kg_to_Q*hlv*fluxes%evap(i,j) + fluxes%latent_evap_diag(i,j) = fluxes%latent(i,j) enddo ; enddo call MOM_read_data(trim(CS%inputdir)//trim(CS%sensibleheat_file), "shflx", & - temp(:,:), G%Domain, timelevel=time_lev) - do j=js,je ; do i=is,ie ; fluxes%sens(i,j) = -temp(i,j) ; enddo ; enddo + fluxes%sens(:,:), G%Domain, timelevel=time_lev, scale=-US%W_m2_to_QRZ_T*) call MOM_read_data(trim(CS%inputdir)//trim(CS%shortwavedown_file), "swdn_sfc", & fluxes%sw(:,:), G%Domain, timelevel=time_lev) @@ -735,8 +732,8 @@ subroutine buoyancy_forcing_from_files(sfc_state, fluxes, day, dt, G, US, CS) fluxes%heat_content_lrunoff(i,j) = US%Q_to_J_kg*fluxes%C_p * & fluxes%lrunoff(i,j)*sfc_state%SST(i,j) fluxes%latent_evap_diag(i,j) = fluxes%latent_evap_diag(i,j) * G%mask2dT(i,j) - fluxes%latent_fprec_diag(i,j) = -US%R_to_kg_m3*US%Z_to_m*US%s_to_T*fluxes%fprec(i,j)*hlf - fluxes%latent_frunoff_diag(i,j) = -US%R_to_kg_m3*US%Z_to_m*US%s_to_T*fluxes%frunoff(i,j)*hlf + fluxes%latent_fprec_diag(i,j) = -fluxes%fprec(i,j)*US%J_kg_to_Q*hlf + fluxes%latent_frunoff_diag(i,j) = -fluxes%frunoff(i,j)*US%J_kg_to_Q*hlf enddo ; enddo endif ! time_lev /= CS%buoy_last_lev_read diff --git a/config_src/mct_driver/mom_surface_forcing_mct.F90 b/config_src/mct_driver/mom_surface_forcing_mct.F90 index 0d7a8af13c..4281c6fed4 100644 --- a/config_src/mct_driver/mom_surface_forcing_mct.F90 +++ b/config_src/mct_driver/mom_surface_forcing_mct.F90 @@ -464,23 +464,23 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, fluxes%heat_content_frunoff(i,j) = 0.0 * G%mask2dT(i,j) if (associated(IOB%calving_hflx)) & - fluxes%heat_content_frunoff(i,j) = kg_m2_s_conversion * IOB%calving_hflx(i-i0,j-j0) * G%mask2dT(i,j) + fluxes%heat_content_frunoff(i,j) = kg_m2_s_conversion * IOB%calving_hflx(i-i0,j-j0) * G%mask2dT(i,j) ! longwave radiation, sum up and down (W/m2) if (associated(IOB%lw_flux)) & - fluxes%lw(i,j) = US%W_m2_to_QRZ_T * IOB%lw_flux(i-i0,j-j0) * G%mask2dT(i,j) + fluxes%lw(i,j) = US%W_m2_to_QRZ_T * IOB%lw_flux(i-i0,j-j0) * G%mask2dT(i,j) ! sensible heat flux (W/m2) if (associated(IOB%t_flux)) & - fluxes%sens(i,j) = IOB%t_flux(i-i0,j-j0) * G%mask2dT(i,j) + fluxes%sens(i,j) = US%W_m2_to_QRZ_T * IOB%t_flux(i-i0,j-j0) * G%mask2dT(i,j) ! sea ice and snow melt heat flux [W/m2] if (associated(IOB%seaice_melt_heat)) & - fluxes%seaice_melt_heat(i,j) = G%mask2dT(i,j) * IOB%seaice_melt_heat(i-i0,j-j0) + fluxes%seaice_melt_heat(i,j) = G%mask2dT(i,j) * US%W_m2_to_QRZ_T * IOB%seaice_melt_heat(i-i0,j-j0) ! water flux due to sea ice and snow melt [kg/m2/s] if (associated(IOB%seaice_melt)) & - fluxes%seaice_melt(i,j) = G%mask2dT(i,j) * kg_m2_s_conversion * IOB%seaice_melt(i-i0,j-j0) + fluxes%seaice_melt(i,j) = G%mask2dT(i,j) * kg_m2_s_conversion * IOB%seaice_melt(i-i0,j-j0) ! latent heat flux (W/m^2) fluxes%latent(i,j) = 0.0 @@ -488,19 +488,19 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, if (associated(IOB%fprec)) then fluxes%latent(i,j) = fluxes%latent(i,j) + & IOB%fprec(i-i0,j-j0)*US%W_m2_to_QRZ_T*CS%latent_heat_fusion - fluxes%latent_fprec_diag(i,j) = G%mask2dT(i,j) * IOB%fprec(i-i0,j-j0)*CS%latent_heat_fusion + fluxes%latent_fprec_diag(i,j) = G%mask2dT(i,j) * IOB%fprec(i-i0,j-j0)*US%W_m2_to_QRZ_T*CS%latent_heat_fusion endif ! contribution from frozen runoff if (associated(fluxes%frunoff)) then fluxes%latent(i,j) = fluxes%latent(i,j) + & IOB%rofi_flux(i-i0,j-j0)*US%W_m2_to_QRZ_T*CS%latent_heat_fusion - fluxes%latent_frunoff_diag(i,j) = G%mask2dT(i,j) * IOB%rofi_flux(i-i0,j-j0)*CS%latent_heat_fusion + fluxes%latent_frunoff_diag(i,j) = G%mask2dT(i,j) * IOB%rofi_flux(i-i0,j-j0)*US%W_m2_to_QRZ_T*CS%latent_heat_fusion endif ! contribution from evaporation if (associated(IOB%q_flux)) then fluxes%latent(i,j) = fluxes%latent(i,j) + & IOB%q_flux(i-i0,j-j0)*US%W_m2_to_QRZ_T*CS%latent_heat_vapor - fluxes%latent_evap_diag(i,j) = G%mask2dT(i,j) * IOB%q_flux(i-i0,j-j0)*CS%latent_heat_vapor + fluxes%latent_evap_diag(i,j) = G%mask2dT(i,j) * IOB%q_flux(i-i0,j-j0)*US%W_m2_to_QRZ_T*CS%latent_heat_vapor endif fluxes%latent(i,j) = G%mask2dT(i,j) * fluxes%latent(i,j) diff --git a/config_src/nuopc_driver/mom_surface_forcing_nuopc.F90 b/config_src/nuopc_driver/mom_surface_forcing_nuopc.F90 index 3b895b19cc..33e18607cd 100644 --- a/config_src/nuopc_driver/mom_surface_forcing_nuopc.F90 +++ b/config_src/nuopc_driver/mom_surface_forcing_nuopc.F90 @@ -468,11 +468,11 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, fluxes%lw(i,j) = US%W_m2_to_QRZ_T * IOB%lw_flux(i-i0,j-j0) * G%mask2dT(i,j) if (associated(IOB%t_flux)) & - fluxes%sens(i,j) = IOB%t_flux(i-i0,j-j0) * G%mask2dT(i,j) + fluxes%sens(i,j) = US%W_m2_to_QRZ_T * IOB%t_flux(i-i0,j-j0) * G%mask2dT(i,j) - ! sea ice and snow melt heat flux [W/m2] + ! sea ice and snow melt heat flux [Q R Z T-1 ~> W/m2] if (associated(IOB%seaice_melt_heat)) & - fluxes%seaice_melt_heat(i,j) = G%mask2dT(i,j) * IOB%seaice_melt_heat(i-i0,j-j0) + fluxes%seaice_melt_heat(i,j) = US%W_m2_to_QRZ_T * G%mask2dT(i,j) * IOB%seaice_melt_heat(i-i0,j-j0) ! water flux due to sea ice and snow melt [kg/m2/s] if (associated(IOB%seaice_melt)) & @@ -482,17 +482,17 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, if (associated(IOB%fprec)) then fluxes%latent(i,j) = fluxes%latent(i,j) + & IOB%fprec(i-i0,j-j0)*US%W_m2_to_QRZ_T*CS%latent_heat_fusion - fluxes%latent_fprec_diag(i,j) = G%mask2dT(i,j) * IOB%fprec(i-i0,j-j0)*CS%latent_heat_fusion + fluxes%latent_fprec_diag(i,j) = G%mask2dT(i,j) * IOB%fprec(i-i0,j-j0)*US%W_m2_to_QRZ_T*CS%latent_heat_fusion endif if (associated(IOB%calving)) then fluxes%latent(i,j) = fluxes%latent(i,j) + & IOB%calving(i-i0,j-j0)*US%W_m2_to_QRZ_T*CS%latent_heat_fusion - fluxes%latent_frunoff_diag(i,j) = G%mask2dT(i,j) * IOB%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)*US%W_m2_to_QRZ_T*CS%latent_heat_fusion endif if (associated(IOB%q_flux)) then fluxes%latent(i,j) = fluxes%latent(i,j) + & IOB%q_flux(i-i0,j-j0)*US%W_m2_to_QRZ_T*CS%latent_heat_vapor - fluxes%latent_evap_diag(i,j) = G%mask2dT(i,j) * IOB%q_flux(i-i0,j-j0)*CS%latent_heat_vapor + fluxes%latent_evap_diag(i,j) = G%mask2dT(i,j) * IOB%q_flux(i-i0,j-j0)*US%W_m2_to_QRZ_T*CS%latent_heat_vapor endif fluxes%latent(i,j) = G%mask2dT(i,j) * fluxes%latent(i,j) diff --git a/config_src/solo_driver/MESO_surface_forcing.F90 b/config_src/solo_driver/MESO_surface_forcing.F90 index 77303d4779..a7bf7df6b0 100644 --- a/config_src/solo_driver/MESO_surface_forcing.F90 +++ b/config_src/solo_driver/MESO_surface_forcing.F90 @@ -150,7 +150,7 @@ subroutine MESO_buoyancy_forcing(sfc_state, fluxes, day, dt, G, US, CS) ! Heat fluxes are in units of [Q R Z T-1 ~> W m-2] and are positive into the ocean. fluxes%lw(i,j) = 0.0 * G%mask2dT(i,j) fluxes%latent(i,j) = 0.0 * G%mask2dT(i,j) - fluxes%sens(i,j) = CS%Heat(i,j) * G%mask2dT(i,j) + fluxes%sens(i,j) = US%W_m2_to_QRZ_T * CS%Heat(i,j) * G%mask2dT(i,j) fluxes%sw(i,j) = CS%Solar(i,j) * G%mask2dT(i,j) enddo ; enddo else ! This is the buoyancy only mode. diff --git a/config_src/solo_driver/MOM_surface_forcing.F90 b/config_src/solo_driver/MOM_surface_forcing.F90 index a978aa02c9..54a46a8e73 100644 --- a/config_src/solo_driver/MOM_surface_forcing.F90 +++ b/config_src/solo_driver/MOM_surface_forcing.F90 @@ -307,7 +307,7 @@ subroutine set_forcing(sfc_state, forces, fluxes, day_start, day_interval, G, US elseif (trim(CS%buoy_config) == "zero") then call buoyancy_forcing_zero(sfc_state, fluxes, day_center, dt, G, CS) elseif (trim(CS%buoy_config) == "const") then - call buoyancy_forcing_const(sfc_state, fluxes, day_center, dt, G, CS) + call buoyancy_forcing_const(sfc_state, fluxes, day_center, dt, G, US, CS) elseif (trim(CS%buoy_config) == "linear") then call buoyancy_forcing_linear(sfc_state, fluxes, day_center, dt, G, US, CS) elseif (trim(CS%buoy_config) == "MESO") then @@ -841,7 +841,7 @@ subroutine buoyancy_forcing_from_files(sfc_state, fluxes, day, dt, G, US, CS) do j=js,je ; do i=is,ie fluxes%latent(i,j) = -US%W_m2_to_QRZ_T*CS%latent_heat_vapor*temp(i,j) fluxes%evap(i,j) = -kg_m2_s_conversion*temp(i,j) - fluxes%latent_evap_diag(i,j) = US%QRZ_T_to_W_m2*fluxes%latent(i,j) + fluxes%latent_evap_diag(i,j) = fluxes%latent(i,j) enddo ; enddo else call MOM_read_data(CS%evaporation_file, CS%evap_var, fluxes%evap(:,:), & @@ -858,7 +858,7 @@ subroutine buoyancy_forcing_from_files(sfc_state, fluxes, day, dt, G, US, CS) call MOM_read_data(CS%latentheat_file, CS%latent_var, fluxes%latent(:,:), & G%Domain, timelevel=time_lev, scale=US%W_m2_to_QRZ_T) do j=js,je ; do i=is,ie - fluxes%latent_evap_diag(i,j) = US%QRZ_T_to_W_m2*fluxes%latent(i,j) + fluxes%latent_evap_diag(i,j) = fluxes%latent(i,j) enddo ; enddo endif CS%latent_last_lev = time_lev @@ -869,12 +869,11 @@ subroutine buoyancy_forcing_from_files(sfc_state, fluxes, day, dt, G, US, CS) case default ; time_lev = 1 end select if (CS%archaic_OMIP_file) then - call MOM_read_data(CS%sensibleheat_file, CS%sens_var, temp(:,:), & - G%Domain, timelevel=time_lev) - do j=js,je ; do i=is,ie ; fluxes%sens(i,j) = -temp(i,j) ; enddo ; enddo + call MOM_read_data(CS%sensibleheat_file, CS%sens_var, fluxes%sens(:,:), & + G%Domain, timelevel=time_lev, scale=-US%W_m2_to_QRZ_T) else call MOM_read_data(CS%sensibleheat_file, CS%sens_var, fluxes%sens(:,:), & - G%Domain, timelevel=time_lev) + G%Domain, timelevel=time_lev, scale=US%W_m2_to_QRZ_T) endif CS%sens_last_lev = time_lev @@ -974,8 +973,8 @@ subroutine buoyancy_forcing_from_files(sfc_state, fluxes, day, dt, G, US, CS) fluxes%latent(i,j) = fluxes%latent(i,j) * G%mask2dT(i,j) fluxes%latent_evap_diag(i,j) = fluxes%latent_evap_diag(i,j) * G%mask2dT(i,j) - fluxes%latent_fprec_diag(i,j) = -fluxes%fprec(i,j)*CS%latent_heat_fusion - fluxes%latent_frunoff_diag(i,j) = -fluxes%frunoff(i,j)*CS%latent_heat_fusion + fluxes%latent_fprec_diag(i,j) = -fluxes%fprec(i,j)*US%W_m2_to_QRZ_T*CS%latent_heat_fusion + fluxes%latent_frunoff_diag(i,j) = -fluxes%frunoff(i,j)*US%W_m2_to_QRZ_T*CS%latent_heat_fusion enddo ; enddo endif ! time_lev /= CS%buoy_last_lev_read @@ -1095,7 +1094,7 @@ subroutine buoyancy_forcing_from_data_override(sfc_state, fluxes, day, dt, G, US fluxes%evap(i,j) = -fluxes%evap(i,j) ! Normal convention is positive into the ocean ! but evap is normally a positive quantity in the files fluxes%latent(i,j) = US%W_m2_to_QRZ_T * CS%latent_heat_vapor*fluxes%evap(i,j) - fluxes%latent_evap_diag(i,j) = US%QRZ_T_to_W_m2*fluxes%latent(i,j) + fluxes%latent_evap_diag(i,j) = fluxes%latent(i,j) fluxes%evap(i,j) = kg_m2_s_conversion*fluxes%evap(i,j) enddo ; enddo @@ -1104,7 +1103,7 @@ subroutine buoyancy_forcing_from_data_override(sfc_state, fluxes, day, dt, G, US ! note the sign convention do j=js,je ; do i=is,ie - fluxes%sens(i,j) = -fluxes%sens(i,j) ! Normal convention is positive into the ocean + fluxes%sens(i,j) = -US%W_m2_to_QRZ_T * fluxes%sens(i,j) ! Normal convention is positive into the ocean ! but sensible is normally a positive quantity in the files enddo ; enddo @@ -1191,8 +1190,8 @@ subroutine buoyancy_forcing_from_data_override(sfc_state, fluxes, day, dt, G, US fluxes%sw(i,j) = fluxes%sw(i,j) * G%mask2dT(i,j) fluxes%latent_evap_diag(i,j) = fluxes%latent_evap_diag(i,j) * G%mask2dT(i,j) - fluxes%latent_fprec_diag(i,j) = -fluxes%fprec(i,j)*CS%latent_heat_fusion - fluxes%latent_frunoff_diag(i,j) = -fluxes%frunoff(i,j)*CS%latent_heat_fusion + fluxes%latent_fprec_diag(i,j) = -fluxes%fprec(i,j)*US%W_m2_to_QRZ_T*CS%latent_heat_fusion + fluxes%latent_frunoff_diag(i,j) = -fluxes%frunoff(i,j)*US%W_m2_to_QRZ_T*CS%latent_heat_fusion enddo ; enddo @@ -1253,7 +1252,7 @@ end subroutine buoyancy_forcing_zero !> Sets up spatially and temporally constant surface heat fluxes. -subroutine buoyancy_forcing_const(sfc_state, fluxes, day, dt, G, CS) +subroutine buoyancy_forcing_const(sfc_state, fluxes, day, dt, G, US, 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 @@ -1261,6 +1260,7 @@ subroutine buoyancy_forcing_const(sfc_state, fluxes, day, dt, G, CS) real, intent(in) :: dt !< The amount of time over which !! the fluxes apply [s] type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(surface_forcing_CS), pointer :: CS !< pointer to control struct returned by !! a previous surface_forcing_init call ! Local variables @@ -1278,7 +1278,7 @@ subroutine buoyancy_forcing_const(sfc_state, fluxes, day, dt, G, CS) fluxes%frunoff(i,j) = 0.0 fluxes%lw(i,j) = 0.0 fluxes%latent(i,j) = 0.0 - fluxes%sens(i,j) = CS%constantHeatForcing * G%mask2dT(i,j) + fluxes%sens(i,j) = US%W_m2_to_QRZ_T * CS%constantHeatForcing * G%mask2dT(i,j) fluxes%sw(i,j) = 0.0 fluxes%latent_evap_diag(i,j) = 0.0 fluxes%latent_fprec_diag(i,j) = 0.0 @@ -1763,7 +1763,6 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, tracer_flow_C elseif (trim(CS%wind_config) == "SCM_CVmix_tests" .or. & trim(CS%buoy_config) == "SCM_CVmix_tests") then call SCM_CVmix_tests_surface_forcing_init(Time, G, param_file, CS%SCM_CVmix_tests_CSp) - CS%SCM_CVmix_tests_CSp%Rho0 = US%R_to_kg_m3*CS%Rho0 !copy reference density for pass endif call register_forcing_type_diags(Time, diag, US, CS%use_temperature, CS%handles) diff --git a/src/core/MOM_forcing_type.F90 b/src/core/MOM_forcing_type.F90 index c6b591b082..a0b563c861 100644 --- a/src/core/MOM_forcing_type.F90 +++ b/src/core/MOM_forcing_type.F90 @@ -68,18 +68,18 @@ module MOM_forcing_type sw_nir_dif => NULL(), & !< near-IR, diffuse shortwave [W m-2] lw => NULL() !< longwave [Q R Z T-1 ~> W m-2] (typically negative) - ! turbulent heat fluxes into the ocean [W m-2] + ! turbulent heat fluxes into the ocean [Q R Z T-1 ~> W m-2] real, pointer, dimension(:,:) :: & latent => NULL(), & !< latent [Q R Z T-1 ~> W m-2] (typically < 0) - sens => NULL(), & !< sensible [W m-2] (typically negative) - seaice_melt_heat => NULL(), & !< sea ice and snow melt or formation [W m-2] (typically negative) + sens => NULL(), & !< sensible [Q R Z T-1 ~> W m-2] (typically negative) + seaice_melt_heat => NULL(), & !< sea ice and snow melt or formation [Q R Z T-1 ~> W m-2] (typically negative) heat_added => NULL() !< additional heat flux from SST restoring or flux adjustments [Q R Z T-1 ~> W m-2] ! components of latent heat fluxes used for diagnostic purposes real, pointer, dimension(:,:) :: & - latent_evap_diag => NULL(), & !< latent [W m-2] from evaporating liquid water (typically < 0) - latent_fprec_diag => NULL(), & !< latent [W m-2] from melting fprec (typically < 0) - latent_frunoff_diag => NULL() !< latent [W m-2] from melting frunoff (calving) (typically < 0) + latent_evap_diag => NULL(), & !< latent [Q R Z T-1 ~> W m-2] from evaporating liquid water (typically < 0) + latent_fprec_diag => NULL(), & !< latent [Q R Z T-1 ~> W m-2] from melting fprec (typically < 0) + latent_frunoff_diag => NULL() !< latent [Q R Z T-1 ~> W m-2] from melting frunoff (calving) (typically < 0) ! water mass fluxes into the ocean [kg m-2 s-1]; these fluxes impact the ocean mass real, pointer, dimension(:,:) :: & @@ -585,18 +585,18 @@ subroutine extractFluxes1d(G, GV, US, fluxes, optics, nsw, j, dt_in_T, & ! CIME provides heat flux from snow&ice melt (seaice_melt_heat), so this is added below if (associated(fluxes%seaice_melt_heat)) then net_heat(i) = scale * dt_in_T * W_m2_to_H_T * & - ( fluxes%sw(i,j) + (US%QRZ_T_to_W_m2*(fluxes%lw(i,j) + fluxes%latent(i,j)) + fluxes%sens(i,j) + & + ( fluxes%sw(i,j) + US%QRZ_T_to_W_m2*(((fluxes%lw(i,j) + fluxes%latent(i,j)) + fluxes%sens(i,j)) + & fluxes%seaice_melt_heat(i,j)) ) !Repeats above code w/ dt=1. for legacy reason if (do_NHR) net_heat_rate(i) = scale * W_m2_to_H_T * & - ( fluxes%sw(i,j) + (US%QRZ_T_to_W_m2*(fluxes%lw(i,j) + fluxes%latent(i,j)) + fluxes%sens(i,j) + & + ( fluxes%sw(i,j) + US%QRZ_T_to_W_m2*(((fluxes%lw(i,j) + fluxes%latent(i,j)) + fluxes%sens(i,j)) + & fluxes%seaice_melt_heat(i,j))) else net_heat(i) = scale * dt_in_T * W_m2_to_H_T * & - ( fluxes%sw(i,j) + (US%QRZ_T_to_W_m2*(fluxes%lw(i,j) + fluxes%latent(i,j)) + fluxes%sens(i,j)) ) + ( fluxes%sw(i,j) + US%QRZ_T_to_W_m2*((fluxes%lw(i,j) + fluxes%latent(i,j)) + fluxes%sens(i,j)) ) !Repeats above code w/ dt=1. for legacy reason if (do_NHR) net_heat_rate(i) = scale * W_m2_to_H_T * & - ( fluxes%sw(i,j) + (US%QRZ_T_to_W_m2*(fluxes%lw(i,j) + fluxes%latent(i,j)) + fluxes%sens(i,j)) ) + ( fluxes%sw(i,j) + US%QRZ_T_to_W_m2*((fluxes%lw(i,j) + fluxes%latent(i,j)) + fluxes%sens(i,j)) ) endif ! Add heat flux from surface damping (restoring) (K * H) or flux adjustments. @@ -1047,13 +1047,16 @@ subroutine MOM_forcing_chksum(mesg, fluxes, G, US, haloshift) if (associated(fluxes%latent)) & call hchksum(fluxes%latent, mesg//" fluxes%latent", G%HI, haloshift=hshift, scale=US%QRZ_T_to_W_m2) if (associated(fluxes%latent_evap_diag)) & - call hchksum(fluxes%latent_evap_diag, mesg//" fluxes%latent_evap_diag",G%HI,haloshift=hshift) + call hchksum(fluxes%latent_evap_diag, mesg//" fluxes%latent_evap_diag", G%HI, & + haloshift=hshift, scale=US%QRZ_T_to_W_m2) if (associated(fluxes%latent_fprec_diag)) & - call hchksum(fluxes%latent_fprec_diag, mesg//" fluxes%latent_fprec_diag",G%HI,haloshift=hshift) + call hchksum(fluxes%latent_fprec_diag, mesg//" fluxes%latent_fprec_diag", G%HI, & + haloshift=hshift, scale=US%QRZ_T_to_W_m2) if (associated(fluxes%latent_frunoff_diag)) & - call hchksum(fluxes%latent_frunoff_diag, mesg//" fluxes%latent_frunoff_diag",G%HI,haloshift=hshift) + call hchksum(fluxes%latent_frunoff_diag, mesg//" fluxes%latent_frunoff_diag", G%HI, & + haloshift=hshift, scale=US%QRZ_T_to_W_m2) if (associated(fluxes%sens)) & - call hchksum(fluxes%sens, mesg//" fluxes%sens",G%HI,haloshift=hshift) + call hchksum(fluxes%sens, mesg//" fluxes%sens",G%HI,haloshift=hshift, scale=US%QRZ_T_to_W_m2) if (associated(fluxes%evap)) & call hchksum(fluxes%evap, mesg//" fluxes%evap",G%HI,haloshift=hshift, scale=RZ_T_conversion) if (associated(fluxes%lprec)) & @@ -1065,7 +1068,8 @@ subroutine MOM_forcing_chksum(mesg, fluxes, G, US, haloshift) if (associated(fluxes%seaice_melt)) & call hchksum(fluxes%seaice_melt, mesg//" fluxes%seaice_melt",G%HI,haloshift=hshift, scale=RZ_T_conversion) if (associated(fluxes%seaice_melt_heat)) & - call hchksum(fluxes%seaice_melt_heat, mesg//" fluxes%seaice_melt_heat",G%HI,haloshift=hshift) + call hchksum(fluxes%seaice_melt_heat, mesg//" fluxes%seaice_melt_heat", G%HI, & + haloshift=hshift, scale=US%QRZ_T_to_W_m2) if (associated(fluxes%p_surf)) & call hchksum(fluxes%p_surf, mesg//" fluxes%p_surf",G%HI,haloshift=hshift) if (associated(fluxes%salt_flux)) & @@ -1564,29 +1568,29 @@ subroutine register_forcing_type_diags(Time, diag, US, use_temperature, handles, cmor_long_name='Surface Downward Latent Heat Flux due to Evap + Melt Snow/Ice') handles%id_lat_evap = register_diag_field('ocean_model', 'latent_evap', diag%axesT1, Time, & - 'Latent heat flux into ocean due to evaporation/condensation', 'W m-2') + 'Latent heat flux into ocean due to evaporation/condensation', 'W m-2', conversion=US%QRZ_T_to_W_m2) handles%id_lat_fprec = register_diag_field('ocean_model', 'latent_fprec_diag', diag%axesT1, Time,& - 'Latent heat flux into ocean due to melting of frozen precipitation', 'W m-2', & + 'Latent heat flux into ocean due to melting of frozen precipitation', 'W m-2', conversion=US%QRZ_T_to_W_m2, & cmor_field_name='hfsnthermds', & cmor_standard_name='heat_flux_into_sea_water_due_to_snow_thermodynamics', & cmor_long_name='Latent Heat to Melt Frozen Precipitation') handles%id_lat_frunoff = register_diag_field('ocean_model', 'latent_frunoff', diag%axesT1, Time, & - 'Latent heat flux into ocean due to melting of icebergs', 'W m-2', & + 'Latent heat flux into ocean due to melting of icebergs', 'W m-2', conversion=US%QRZ_T_to_W_m2, & cmor_field_name='hfibthermds', & cmor_standard_name='heat_flux_into_sea_water_due_to_iceberg_thermodynamics', & cmor_long_name='Latent Heat to Melt Frozen Runoff/Iceberg') - handles%id_sens = register_diag_field('ocean_model', 'sensible', diag%axesT1, Time,& - 'Sensible heat flux into ocean', 'W m-2', & + handles%id_sens = register_diag_field('ocean_model', 'sensible', diag%axesT1, Time, & + 'Sensible heat flux into ocean', 'W m-2', conversion=US%QRZ_T_to_W_m2, & standard_name='surface_downward_sensible_heat_flux', & cmor_field_name='hfsso', & cmor_standard_name='surface_downward_sensible_heat_flux', & cmor_long_name='Surface Downward Sensible Heat Flux') handles%id_seaice_melt_heat = register_diag_field('ocean_model', 'seaice_melt_heat', diag%axesT1, Time,& - 'Heat flux into ocean due to snow and sea ice melt/freeze', 'W m-2', & + 'Heat flux into ocean due to snow and sea ice melt/freeze', 'W m-2', conversion=US%QRZ_T_to_W_m2, & standard_name='snow_ice_melt_heat_flux', & !GMM TODO cmor_field_name='hfsso', & cmor_standard_name='snow_ice_melt_heat_flux', & @@ -2513,9 +2517,9 @@ subroutine forcing_diagnostics(fluxes, sfc_state, G, US, time_end, diag, handles res(i,j) = 0.0 if (associated(fluxes%LW)) res(i,j) = res(i,j) + US%QRZ_T_to_W_m2*fluxes%lw(i,j) if (associated(fluxes%latent)) res(i,j) = res(i,j) + US%QRZ_T_to_W_m2*fluxes%latent(i,j) - if (associated(fluxes%sens)) res(i,j) = res(i,j) + fluxes%sens(i,j) + if (associated(fluxes%sens)) res(i,j) = res(i,j) + US%QRZ_T_to_W_m2*fluxes%sens(i,j) if (associated(fluxes%SW)) res(i,j) = res(i,j) + fluxes%SW(i,j) - if (associated(fluxes%seaice_melt_heat)) res(i,j) = res(i,j) + fluxes%seaice_melt_heat(i,j) + if (associated(fluxes%seaice_melt_heat)) res(i,j) = res(i,j) + US%QRZ_T_to_W_m2*fluxes%seaice_melt_heat(i,j) enddo ; enddo if (handles%id_net_heat_coupler > 0) call post_data(handles%id_net_heat_coupler, res, diag) if (handles%id_total_net_heat_coupler > 0) then @@ -2534,9 +2538,9 @@ subroutine forcing_diagnostics(fluxes, sfc_state, G, US, time_end, diag, handles res(i,j) = 0.0 if (associated(fluxes%LW)) res(i,j) = res(i,j) + US%QRZ_T_to_W_m2*fluxes%lw(i,j) if (associated(fluxes%latent)) res(i,j) = res(i,j) + US%QRZ_T_to_W_m2*fluxes%latent(i,j) - if (associated(fluxes%sens)) res(i,j) = res(i,j) + fluxes%sens(i,j) + if (associated(fluxes%sens)) res(i,j) = res(i,j) + US%QRZ_T_to_W_m2*fluxes%sens(i,j) if (associated(fluxes%SW)) res(i,j) = res(i,j) + fluxes%SW(i,j) - if (associated(fluxes%seaice_melt_heat)) res(i,j) = res(i,j) + fluxes%seaice_melt_heat(i,j) + if (associated(fluxes%seaice_melt_heat)) res(i,j) = res(i,j) + US%QRZ_T_to_W_m2*fluxes%seaice_melt_heat(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) * US%Q_to_J_kg*fluxes%C_p * I_dt @@ -2619,7 +2623,7 @@ subroutine forcing_diagnostics(fluxes, sfc_state, G, US, time_end, diag, handles 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) = US%QRZ_T_to_W_m2*(fluxes%lw(i,j) + fluxes%latent(i,j)) + fluxes%sens(i,j) + res(i,j) = US%QRZ_T_to_W_m2*((fluxes%lw(i,j) + fluxes%latent(i,j)) + fluxes%sens(i,j)) enddo ; enddo call post_data(handles%id_LwLatSens, res, diag) endif @@ -2627,7 +2631,7 @@ subroutine forcing_diagnostics(fluxes, sfc_state, G, US, time_end, diag, handles 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) = US%QRZ_T_to_W_m2*(fluxes%lw(i,j) + fluxes%latent(i,j)) + fluxes%sens(i,j) + res(i,j) = US%QRZ_T_to_W_m2*((fluxes%lw(i,j) + fluxes%latent(i,j)) + fluxes%sens(i,j)) enddo ; enddo total_transport = global_area_integral(res,G) call post_data(handles%id_total_LwLatSens, total_transport, diag) @@ -2636,7 +2640,7 @@ subroutine forcing_diagnostics(fluxes, sfc_state, G, US, time_end, diag, handles 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) = US%QRZ_T_to_W_m2*(fluxes%lw(i,j) + fluxes%latent(i,j)) + fluxes%sens(i,j) + res(i,j) = US%QRZ_T_to_W_m2*((fluxes%lw(i,j) + fluxes%latent(i,j)) + fluxes%sens(i,j)) enddo ; enddo ave_flux = global_area_mean(res,G) call post_data(handles%id_LwLatSens_ga, ave_flux, diag) @@ -2690,7 +2694,7 @@ subroutine forcing_diagnostics(fluxes, sfc_state, G, US, time_end, diag, handles 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 - total_transport = global_area_integral(fluxes%latent_evap_diag,G) + total_transport = global_area_integral(fluxes%latent_evap_diag, G, scale=US%QRZ_T_to_W_m2) call post_data(handles%id_total_lat_evap, total_transport, diag) endif @@ -2698,7 +2702,7 @@ subroutine forcing_diagnostics(fluxes, sfc_state, G, US, time_end, diag, handles 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 - total_transport = global_area_integral(fluxes%latent_fprec_diag,G) + total_transport = global_area_integral(fluxes%latent_fprec_diag, G, scale=US%QRZ_T_to_W_m2) call post_data(handles%id_total_lat_fprec, total_transport, diag) endif @@ -2706,7 +2710,7 @@ subroutine forcing_diagnostics(fluxes, sfc_state, G, US, time_end, diag, handles 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 - total_transport = global_area_integral(fluxes%latent_frunoff_diag,G) + total_transport = global_area_integral(fluxes%latent_frunoff_diag, G, scale=US%QRZ_T_to_W_m2) call post_data(handles%id_total_lat_frunoff, total_transport, diag) endif @@ -2719,16 +2723,16 @@ subroutine forcing_diagnostics(fluxes, sfc_state, G, US, time_end, diag, handles endif if ((handles%id_total_seaice_melt_heat > 0) .and. associated(fluxes%seaice_melt_heat)) then - total_transport = global_area_integral(fluxes%seaice_melt_heat,G) + total_transport = global_area_integral(fluxes%seaice_melt_heat, G, scale=US%QRZ_T_to_W_m2) call post_data(handles%id_total_seaice_melt_heat, total_transport, diag) endif if ((handles%id_total_sens > 0) .and. associated(fluxes%sens)) then - total_transport = global_area_integral(fluxes%sens,G) + total_transport = global_area_integral(fluxes%sens, G, scale=US%QRZ_T_to_W_m2) call post_data(handles%id_total_sens, total_transport, diag) endif if ((handles%id_sens_ga > 0) .and. associated(fluxes%sens)) then - ave_flux = global_area_mean(fluxes%sens,G) + ave_flux = global_area_mean(fluxes%sens, G, scale=US%QRZ_T_to_W_m2) call post_data(handles%id_sens_ga, ave_flux, diag) endif diff --git a/src/diagnostics/MOM_sum_output.F90 b/src/diagnostics/MOM_sum_output.F90 index 54c30cb523..7b56bc5705 100644 --- a/src/diagnostics/MOM_sum_output.F90 +++ b/src/diagnostics/MOM_sum_output.F90 @@ -1001,11 +1001,12 @@ subroutine accumulate_net_input(fluxes, sfc_state, tv, dt, G, US, CS) if (associated(fluxes%sw)) then ; do j=js,je ; do i=is,ie heat_in(i,j) = heat_in(i,j) + dt*US%T_to_s*US%L_to_m**2*G%areaT(i,j) * (fluxes%sw(i,j) + & - (US%QRZ_T_to_W_m2*fluxes%lw(i,j) + (US%QRZ_T_to_W_m2*fluxes%latent(i,j) + fluxes%sens(i,j)))) + US%QRZ_T_to_W_m2*(fluxes%lw(i,j) + (fluxes%latent(i,j) + fluxes%sens(i,j)))) enddo ; enddo ; endif if (associated(fluxes%seaice_melt_heat)) then ; do j=js,je ; do i=is,ie - heat_in(i,j) = heat_in(i,j) + dt*US%T_to_s*US%L_to_m**2*G%areaT(i,j) * fluxes%seaice_melt_heat(i,j) + heat_in(i,j) = heat_in(i,j) + dt*US%T_to_s*US%L_to_m**2*US%QRZ_T_to_W_m2*G%areaT(i,j) * & + fluxes%seaice_melt_heat(i,j) enddo ; enddo ; endif ! smg: new code diff --git a/src/ice_shelf/MOM_ice_shelf.F90 b/src/ice_shelf/MOM_ice_shelf.F90 index d82910df81..e5a29245bc 100644 --- a/src/ice_shelf/MOM_ice_shelf.F90 +++ b/src/ice_shelf/MOM_ice_shelf.F90 @@ -975,7 +975,7 @@ subroutine add_shelf_flux(G, US, CS, state, fluxes) endif if (associated(fluxes%sens)) & - fluxes%sens(i,j) = -frac_area*ISS%tflux_ocn(i,j)*CS%flux_factor + fluxes%sens(i,j) = -frac_area*ISS%tflux_ocn(i,j)*US%W_m2_to_QRZ_T*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 @@ -1059,7 +1059,7 @@ subroutine add_shelf_flux(G, US, CS, state, fluxes) ! 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%sens(i,j) = US%W_m2_to_QRZ_T*fluxes%vprec(i,j) * CS%Cp * CS%T0 ! W /m^2 ! Rescale fluxes%vprec to the proper units. fluxes%vprec(i,j) = US%kg_m3_to_R*US%m_to_Z*US%T_to_s * fluxes%vprec(i,j) fluxes%salt_flux(i,j) = fluxes%vprec(i,j) * CS%S0*1.0e-3 ! kg (salt)/(m^2 s) diff --git a/src/user/SCM_CVMix_tests.F90 b/src/user/SCM_CVMix_tests.F90 index ce891bda20..f9ba5bc724 100644 --- a/src/user/SCM_CVMix_tests.F90 +++ b/src/user/SCM_CVMix_tests.F90 @@ -38,10 +38,10 @@ module SCM_CVMix_tests logical :: UseDiurnalSW !< True to use diurnal sw radiation real :: tau_x !< (Constant) Wind stress, X [Pa] real :: tau_y !< (Constant) Wind stress, Y [Pa] - real :: surf_HF !< (Constant) Heat flux [m degC s-1] - real :: surf_evap !< (Constant) Evaporation rate [m s-1] + real :: surf_HF !< (Constant) Heat flux [degC Z T-1 ~> m degC s-1] + real :: surf_evap !< (Constant) Evaporation rate [Z T-1 ~> m s-1] real :: Max_sw !< maximum of diurnal sw radiation [m degC s-1] - real,public :: Rho0 !< reference density copied for easy passing [kg m-3] + real :: Rho0 !< reference density [R ~> kg m-3] end type ! This include declares and sets the variable "version". @@ -177,13 +177,13 @@ subroutine SCM_CVMix_tests_surface_forcing_init(Time, G, param_file, CS) call get_param(param_file, mdl, "SCM_HEAT_FLUX", & CS%surf_HF, "Constant surface heat flux "// & "used in the SCM CVMix test surface forcing.", & - units='m K/s', fail_if_missing=.true.) + units='m K/s', scale=US%m_to_Z*US%T_to_s, fail_if_missing=.true.) endif if (CS%UseEvaporation) then call get_param(param_file, mdl, "SCM_EVAPORATION", & CS%surf_evap, "Constant surface evaporation "// & "used in the SCM CVMix test surface forcing.", & - units='m/s', fail_if_missing=.true.) + units='m/s', scale=US%m_to_Z*US%T_to_s, fail_if_missing=.true.) endif if (CS%UseDiurnalSW) then call get_param(param_file, mdl, "SCM_DIURNAL_SW_MAX", & @@ -191,6 +191,12 @@ subroutine SCM_CVMix_tests_surface_forcing_init(Time, G, param_file, CS) "used in the SCM CVMix test surface forcing.", & units='m K/s', fail_if_missing=.true.) endif + call get_param(param_file, mdl, "RHO_0", CS%Rho0, & + "The mean ocean density used with BOUSSINESQ true to "//& + "calculate accelerations and the mass for conservation "//& + "properties, or with BOUSSINSEQ false to convert some "//& + "parameters from vertical units of m to kg m-2.", & + units="kg m-3", default=1035.0, scale=US%kg_m3_to_R) end subroutine SCM_CVMix_tests_surface_forcing_init @@ -221,7 +227,7 @@ subroutine SCM_CVMix_tests_wind_forcing(state, forces, day, G, US, CS) mag_tau = sqrt(CS%tau_x*CS%tau_x + CS%tau_y*CS%tau_y) if (associated(forces%ustar)) then ; do j=js,je ; do i=is,ie - forces%ustar(i,j) = sqrt( US%L_to_Z * mag_tau / (US%kg_m3_to_R*CS%Rho0) ) + forces%ustar(i,j) = sqrt( US%L_to_Z * mag_tau / (CS%Rho0) ) enddo ; enddo ; endif end subroutine SCM_CVMix_tests_wind_forcing @@ -253,7 +259,7 @@ subroutine SCM_CVMix_tests_buoyancy_forcing(state, fluxes, day, G, US, CS) ! therefore must convert to W/m2 by multiplying ! by Rho0*Cp do J=Jsq,Jeq ; do i=is,ie - fluxes%sens(i,J) = CS%surf_HF * CS%Rho0 * US%Q_to_J_kg*fluxes%C_p + fluxes%sens(i,J) = CS%surf_HF * CS%Rho0 * fluxes%C_p enddo ; enddo endif @@ -262,7 +268,7 @@ subroutine SCM_CVMix_tests_buoyancy_forcing(state, fluxes, day, G, US, CS) ! Note CVMix test inputs give evaporation in [m s-1] ! This therefore must be converted to mass flux in [R Z T-1 ~> kg m-2 s-1] ! by multiplying by density and some unit conversion factors. - fluxes%evap(i,J) = CS%surf_evap * US%kg_m3_to_R*US%m_to_Z*US%T_to_s * CS%Rho0 + fluxes%evap(i,J) = CS%surf_evap * CS%Rho0 enddo ; enddo endif From c7e93c980059d0915600cff1d9186912de521c73 Mon Sep 17 00:00:00 2001 From: Kate Hedstrom Date: Fri, 14 Feb 2020 06:36:13 -0900 Subject: [PATCH 068/316] Adding limiter to oblique OBC --- src/core/MOM_open_boundary.F90 | 4 ++ src/user/Kelvin_initialization.F90 | 66 +++++++++++++++++------------- 2 files changed, 41 insertions(+), 29 deletions(-) diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index 822ca6486f..68efc26caa 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -1962,6 +1962,7 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, US, dt) if (dhdt*dhdx < 0.0) dhdt = 0.0 rx_new = dhdt*dhdx cff_new = max(dhdx*dhdx + dhdy*dhdy, eps) + rx_new = min(rx_new, cff_new*rx_max) ry_new = min(cff_new,max(dhdt*dhdy,-cff_new)) if (gamma_u < 1.0) then rx_avg = (1.0-gamma_u)*segment%rx_norm_obl(I,j,k) + gamma_u*rx_new @@ -2207,6 +2208,7 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, US, dt) rx_new = dhdt*dhdx cff_new = max(dhdx*dhdx + dhdy*dhdy, eps) + rx_new = min(rx_new, cff_new*rx_max) ry_new = min(cff_new,max(dhdt*dhdy,-cff_new)) if (gamma_u < 1.0) then rx_avg = (1.0-gamma_u)*segment%rx_norm_obl(I,j,k) + gamma_u*rx_new @@ -2451,6 +2453,7 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, US, dt) if (dhdt*dhdy < 0.0) dhdt = 0.0 ry_new = dhdt*dhdy cff_new = max(dhdx*dhdx + dhdy*dhdy, eps) + ry_new = min(ry_new, cff_new*ry_max) rx_new = min(cff_new,max(dhdt*dhdx,-cff_new)) if (gamma_u < 1.0) then rx_avg = (1.0-gamma_u)*segment%rx_norm_obl(I,j,k) + gamma_u*rx_new @@ -2696,6 +2699,7 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, US, dt) ry_new = dhdt*dhdy cff_new = max(dhdx*dhdx + dhdy*dhdy, eps) + ry_new = min(ry_new, cff_new*ry_max) rx_new = min(cff_new,max(dhdt*dhdx,-cff_new)) if (gamma_u < 1.0) then rx_avg = (1.0-gamma_u)*segment%rx_norm_obl(I,j,k) + gamma_u*rx_new diff --git a/src/user/Kelvin_initialization.F90 b/src/user/Kelvin_initialization.F90 index c211341493..6eade35bad 100644 --- a/src/user/Kelvin_initialization.F90 +++ b/src/user/Kelvin_initialization.F90 @@ -258,6 +258,18 @@ subroutine Kelvin_set_OBC_data(OBC, CS, G, GV, US, h, Time) segment%eta(I,j) = val2 * cos(omega * time_sec) segment%normal_vel_bt(I,j) = (val2 * (val1 * cff * cosa / & (0.5 * (G%bathyT(i+1,j) + G%bathyT(i,j)))) ) + if (segment%nudged) then + do k=1,nz + segment%nudged_normal_vel(I,j,k) = (val2 * (val1 * cff * cosa / & + (0.5 * (G%bathyT(i+1,j) + G%bathyT(i,j)))) ) + enddo + elseif (segment%specified) then + do k=1,nz + segment%normal_vel(I,j,k) = (val2 * (val1 * cff * cosa / & + (0.5 * (G%bathyT(i+1,j) + G%bathyT(i,j)))) ) + segment%normal_trans(I,j,k) = segment%normal_vel(I,j,k) * h(i+1,j,k) * G%dyCu(I,j) + enddo + endif else ! Not rotated yet segment%eta(I,j) = 0.0 @@ -284,21 +296,13 @@ subroutine Kelvin_set_OBC_data(OBC, CS, G, GV, US, h, Time) y1 = 1000. * G%geoLatBu(I,J) x = (x1 - CS%coast_offset1) * cosa + y1 * sina y = - (x1 - CS%coast_offset1) * sina + y1 * cosa - if (CS%answers_2018) then - ! Problem: val2 & cff could be functions of space, but are not set in this loop. - if (CS%mode == 0) then ; do k=1,nz - segment%tangential_vel(I,J,k) = (val2 * (val1 * cff * sina / & - (0.25 * (G%bathyT(i+1,j) + G%bathyT(i,j) + G%bathyT(i+1,j+1) + G%bathyT(i,j+1))) )) - enddo ; endif - else - cff =sqrt(GV%g_Earth * 0.5 * (G%bathyT(i+1,j) + G%bathyT(i,j))) - val2 = fac * exp(- US%T_to_s*CS%F_0 * US%m_to_L*y / cff) - if (CS%mode == 0) then ; do k=1,nz - segment%tangential_vel(I,J,k) = (val1 * val2 * cff * sina) / & - ( 0.25*((G%bathyT(i,j) + G%bathyT(i+1,j+1)) + (G%bathyT(i+1,j) + G%bathyT(i,j+1))) ) - - enddo ; endif - endif + cff =sqrt(GV%g_Earth * 0.5 * (G%bathyT(i+1,j) + G%bathyT(i,j))) + val2 = fac * exp(- US%T_to_s*CS%F_0 * US%m_to_L*y / cff) + if (CS%mode == 0) then ; do k=1,nz + segment%tangential_vel(I,J,k) = (val1 * val2 * cff * sina) / & + ( 0.25*((G%bathyT(i,j) + G%bathyT(i+1,j+1)) + (G%bathyT(i+1,j) + G%bathyT(i,j+1))) ) + + enddo ; endif enddo ; enddo endif else @@ -315,6 +319,18 @@ subroutine Kelvin_set_OBC_data(OBC, CS, G, GV, US, h, Time) segment%eta(I,j) = val2 * cos(omega * time_sec) segment%normal_vel_bt(I,j) = US%L_T_to_m_s * (val1 * cff * sina / & (0.5*(G%bathyT(i+1,j) + G%bathyT(i,j)))) * val2 + if (segment%nudged) then + do k=1,nz + segment%nudged_normal_vel(I,j,k) = US%L_T_to_m_s * (val1 * cff * sina / & + (0.5*(G%bathyT(i+1,j) + G%bathyT(i,j)))) * val2 + enddo + elseif (segment%specified) then + do k=1,nz + segment%normal_vel(I,j,k) = US%L_T_to_m_s * (val1 * cff * sina / & + (0.5*(G%bathyT(i+1,j) + G%bathyT(i,j)))) * val2 + segment%normal_trans(i,J,k) = segment%normal_vel(i,J,k) * h(i,j+1,k) * G%dxCv(i,J) + enddo + endif else ! Not rotated yet segment%eta(i,J) = 0.0 @@ -339,20 +355,12 @@ subroutine Kelvin_set_OBC_data(OBC, CS, G, GV, US, h, Time) y1 = 1000. * G%geoLatBu(I,J) x = (x1 - CS%coast_offset1) * cosa + y1 * sina y = - (x1 - CS%coast_offset1) * sina + y1 * cosa - if (CS%answers_2018) then - ! Problem: val2 & cff could be functions of space, but are not set in this loop. - if (CS%mode == 0) then ; do k=1,nz - segment%tangential_vel(I,J,k) = (val2 * (val1 * cff * sina / & - (0.25*(G%bathyT(i+1,j) + G%bathyT(i,j) + G%bathyT(i+1,j+1) + G%bathyT(i,j+1))))) - enddo ; endif - else - cff = sqrt(GV%g_Earth * 0.5 * (G%bathyT(i,j+1) + G%bathyT(i,j))) - val2 = fac * exp(- 0.5 * (G%CoriolisBu(I,J) + G%CoriolisBu(I-1,J)) * US%m_to_L*y / cff) - if (CS%mode == 0) then ; do k=1,nz - segment%tangential_vel(I,J,k) = ((val1 * val2 * cff * sina) / & - ( 0.25*((G%bathyT(i,j) + G%bathyT(i+1,j+1)) + (G%bathyT(i+1,j) + G%bathyT(i,j+1))) )) - enddo ; endif - endif + cff = sqrt(GV%g_Earth * 0.5 * (G%bathyT(i,j+1) + G%bathyT(i,j))) + val2 = fac * exp(- 0.5 * (G%CoriolisBu(I,J) + G%CoriolisBu(I-1,J)) * US%m_to_L*y / cff) + if (CS%mode == 0) then ; do k=1,nz + segment%tangential_vel(I,J,k) = ((val1 * val2 * cff * sina) / & + ( 0.25*((G%bathyT(i,j) + G%bathyT(i+1,j+1)) + (G%bathyT(i+1,j) + G%bathyT(i,j+1))) )) + enddo ; endif enddo ; enddo endif endif From a5182cad329f7c71c1b5f7b7705e012cb48db8d9 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 14 Feb 2020 15:22:32 -0500 Subject: [PATCH 069/316] +Rescaled units of fluxes%sw Rescaled the units of fluxes%sw, fluxes%sw_[nir|vis]_[dir|dif] to [Q R Z T-1] for dimensional consistency testing. New units_scale_type arguments are being passed to some of the opacity routines to accommodate the rescaling. All answers are bitwise identical. --- .../MOM_surface_forcing_gfdl.F90 | 13 ++-- .../ice_solo_driver/MOM_surface_forcing.F90 | 6 +- .../mct_driver/mom_surface_forcing_mct.F90 | 8 +-- .../mom_surface_forcing_nuopc.F90 | 8 +-- .../solo_driver/MESO_surface_forcing.F90 | 22 +++---- .../solo_driver/MOM_surface_forcing.F90 | 15 +++-- src/core/MOM_forcing_type.F90 | 62 +++++++++---------- src/diagnostics/MOM_sum_output.F90 | 4 +- .../vertical/MOM_diabatic_aux.F90 | 9 +-- .../vertical/MOM_diabatic_driver.F90 | 6 +- .../vertical/MOM_entrain_diffusive.F90 | 2 +- .../vertical/MOM_opacity.F90 | 60 +++++++++--------- src/tracer/MOM_offline_aux.F90 | 14 ++--- src/tracer/MOM_offline_main.F90 | 6 +- src/user/SCM_CVMix_tests.F90 | 12 ++-- 15 files changed, 125 insertions(+), 122 deletions(-) diff --git a/config_src/coupled_driver/MOM_surface_forcing_gfdl.F90 b/config_src/coupled_driver/MOM_surface_forcing_gfdl.F90 index ec5b53d79d..384f7c2e4c 100644 --- a/config_src/coupled_driver/MOM_surface_forcing_gfdl.F90 +++ b/config_src/coupled_driver/MOM_surface_forcing_gfdl.F90 @@ -513,27 +513,28 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, fluxes%latent(i,j) = G%mask2dT(i,j) * fluxes%latent(i,j) if (associated(IOB%sw_flux_vis_dir)) then - fluxes%sw_vis_dir(i,j) = G%mask2dT(i,j) * IOB%sw_flux_vis_dir(i-i0,j-j0) + fluxes%sw_vis_dir(i,j) = G%mask2dT(i,j) * US%W_m2_to_QRZ_T * IOB%sw_flux_vis_dir(i-i0,j-j0) if (CS%check_no_land_fluxes) & call check_mask_val_consistency(IOB%sw_flux_vis_dir(i-i0,j-j0), G%mask2dT(i,j), i, j, 'sw_flux_vis_dir', G) endif if (associated(IOB%sw_flux_vis_dif)) then - fluxes%sw_vis_dif(i,j) = G%mask2dT(i,j) * IOB%sw_flux_vis_dif(i-i0,j-j0) + fluxes%sw_vis_dif(i,j) = G%mask2dT(i,j) * US%W_m2_to_QRZ_T * IOB%sw_flux_vis_dif(i-i0,j-j0) if (CS%check_no_land_fluxes) & call check_mask_val_consistency(IOB%sw_flux_vis_dif(i-i0,j-j0), G%mask2dT(i,j), i, j, 'sw_flux_vis_dif', G) endif if (associated(IOB%sw_flux_nir_dir)) then - fluxes%sw_nir_dir(i,j) = G%mask2dT(i,j) * IOB%sw_flux_nir_dir(i-i0,j-j0) + fluxes%sw_nir_dir(i,j) = G%mask2dT(i,j) * US%W_m2_to_QRZ_T * IOB%sw_flux_nir_dir(i-i0,j-j0) if (CS%check_no_land_fluxes) & call check_mask_val_consistency(IOB%sw_flux_nir_dir(i-i0,j-j0), G%mask2dT(i,j), i, j, 'sw_flux_nir_dir', G) endif if (associated(IOB%sw_flux_nir_dif)) then - fluxes%sw_nir_dif(i,j) = G%mask2dT(i,j) * IOB%sw_flux_nir_dif(i-i0,j-j0) + fluxes%sw_nir_dif(i,j) = G%mask2dT(i,j) * US%W_m2_to_QRZ_T * IOB%sw_flux_nir_dif(i-i0,j-j0) if (CS%check_no_land_fluxes) & call check_mask_val_consistency(IOB%sw_flux_nir_dif(i-i0,j-j0), G%mask2dT(i,j), i, j, 'sw_flux_nir_dif', G) endif - 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) + ! The parentheses here reproduce what most compilers do without any parentheses. + 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 diff --git a/config_src/ice_solo_driver/MOM_surface_forcing.F90 b/config_src/ice_solo_driver/MOM_surface_forcing.F90 index fd11a6f5a8..d736574f2a 100644 --- a/config_src/ice_solo_driver/MOM_surface_forcing.F90 +++ b/config_src/ice_solo_driver/MOM_surface_forcing.F90 @@ -675,12 +675,12 @@ subroutine buoyancy_forcing_from_files(sfc_state, fluxes, day, dt, G, US, CS) enddo ; enddo call MOM_read_data(trim(CS%inputdir)//trim(CS%sensibleheat_file), "shflx", & - fluxes%sens(:,:), G%Domain, timelevel=time_lev, scale=-US%W_m2_to_QRZ_T*) + fluxes%sens(:,:), G%Domain, timelevel=time_lev, scale=-US%W_m2_to_QRZ_T) call MOM_read_data(trim(CS%inputdir)//trim(CS%shortwavedown_file), "swdn_sfc", & - fluxes%sw(:,:), G%Domain, timelevel=time_lev) + fluxes%sw(:,:), G%Domain, timelevel=time_lev, scale=US%W_m2_to_QRZ_T) call MOM_read_data(trim(CS%inputdir)//trim(CS%shortwaveup_file), "swup_sfc", & - temp(:,:), G%Domain, timelevel=time_lev) + temp(:,:), G%Domain, timelevel=time_lev, scale=US%W_m2_to_QRZ_T) do j=js,je ; do i=is,ie fluxes%sw(i,j) = fluxes%sw(i,j) - temp(i,j) enddo ; enddo diff --git a/config_src/mct_driver/mom_surface_forcing_mct.F90 b/config_src/mct_driver/mom_surface_forcing_mct.F90 index 4281c6fed4..61c43bf44c 100644 --- a/config_src/mct_driver/mom_surface_forcing_mct.F90 +++ b/config_src/mct_driver/mom_surface_forcing_mct.F90 @@ -505,16 +505,16 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, fluxes%latent(i,j) = G%mask2dT(i,j) * fluxes%latent(i,j) 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) + fluxes%sw_vis_dir(i,j) = G%mask2dT(i,j) * US%W_m2_to_QRZ_T * 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) + fluxes%sw_vis_dif(i,j) = G%mask2dT(i,j) * US%W_m2_to_QRZ_T * 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) + fluxes%sw_nir_dir(i,j) = G%mask2dT(i,j) * US%W_m2_to_QRZ_T * 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_nir_dif(i,j) = G%mask2dT(i,j) * US%W_m2_to_QRZ_T * 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) diff --git a/config_src/nuopc_driver/mom_surface_forcing_nuopc.F90 b/config_src/nuopc_driver/mom_surface_forcing_nuopc.F90 index 33e18607cd..03158b932e 100644 --- a/config_src/nuopc_driver/mom_surface_forcing_nuopc.F90 +++ b/config_src/nuopc_driver/mom_surface_forcing_nuopc.F90 @@ -497,16 +497,16 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, fluxes%latent(i,j) = G%mask2dT(i,j) * fluxes%latent(i,j) 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) + fluxes%sw_vis_dir(i,j) = G%mask2dT(i,j) * US%W_m2_to_QRZ_T * 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) + fluxes%sw_vis_dif(i,j) = G%mask2dT(i,j) * US%W_m2_to_QRZ_T * 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) + fluxes%sw_nir_dir(i,j) = G%mask2dT(i,j) * US%W_m2_to_QRZ_T * 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_nir_dif(i,j) = G%mask2dT(i,j) * US%W_m2_to_QRZ_T * 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) diff --git a/config_src/solo_driver/MESO_surface_forcing.F90 b/config_src/solo_driver/MESO_surface_forcing.F90 index a7bf7df6b0..ebe98a3293 100644 --- a/config_src/solo_driver/MESO_surface_forcing.F90 +++ b/config_src/solo_driver/MESO_surface_forcing.F90 @@ -35,10 +35,10 @@ module MESO_surface_forcing real, dimension(:,:), pointer :: & T_Restore(:,:) => NULL(), & !< The temperature to restore the SST toward [degC]. S_Restore(:,:) => NULL(), & !< The salinity to restore the sea surface salnity toward [ppt] - PmE(:,:) => NULL(), & !< The prescribed precip minus evap [m s-1]. - Solar(:,:) => NULL() !< The shortwave forcing into the ocean [W m-2]. + PmE(:,:) => NULL(), & !< The prescribed precip minus evap [Z T-1 ~> m s-1]. + Solar(:,:) => NULL() !< The shortwave forcing into the ocean [Q R Z T-1 ~> W m-2]. real, dimension(:,:), pointer :: Heat(:,:) => NULL() !< The prescribed longwave, latent and sensible - !! heat flux into the ocean [W m-2]. + !! heat flux into the ocean [Q R Z T-1 ~> W m-2]. character(len=200) :: inputdir !< The directory where NetCDF input files are. character(len=200) :: salinityrestore_file !< The file with the target sea surface salinity character(len=200) :: SSTrestore_file !< The file with the target sea surface temperature @@ -127,11 +127,11 @@ subroutine MESO_buoyancy_forcing(sfc_state, fluxes, day, dt, G, US, CS) call MOM_read_data(trim(CS%inputdir)//trim(CS%salinityrestore_file), "SAL", & CS%S_Restore(:,:), G%Domain) call MOM_read_data(trim(CS%inputdir)//trim(CS%heating_file), "Heat", & - CS%Heat(:,:), G%Domain) + CS%Heat(:,:), G%Domain, scale=US%W_m2_to_QRZ_T) call MOM_read_data(trim(CS%inputdir)//trim(CS%PmE_file), "PmE", & - CS%PmE(:,:), G%Domain) + CS%PmE(:,:), G%Domain, scale=US%m_to_Z*US%T_to_s) call MOM_read_data(trim(CS%inputdir)//trim(CS%Solar_file), "NET_SOL", & - CS%Solar(:,:), G%Domain) + CS%Solar(:,:), G%Domain, scale=US%W_m2_to_QRZ_T) first_call = .false. endif @@ -142,16 +142,16 @@ subroutine MESO_buoyancy_forcing(sfc_state, fluxes, day, dt, G, US, 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%lprec(i,j) = US%m_to_Z*US%T_to_s * CS%PmE(i,j) * CS%Rho0 * G%mask2dT(i,j) + fluxes%lprec(i,j) = CS%PmE(i,j) * CS%Rho0 * G%mask2dT(i,j) ! vprec will be set later, if it is needed for salinity restoring. fluxes%vprec(i,j) = 0.0 ! Heat fluxes are in units of [Q R Z T-1 ~> W m-2] and are positive into the ocean. - fluxes%lw(i,j) = 0.0 * G%mask2dT(i,j) - fluxes%latent(i,j) = 0.0 * G%mask2dT(i,j) - fluxes%sens(i,j) = US%W_m2_to_QRZ_T * CS%Heat(i,j) * G%mask2dT(i,j) - fluxes%sw(i,j) = CS%Solar(i,j) * G%mask2dT(i,j) + fluxes%lw(i,j) = 0.0 * G%mask2dT(i,j) + fluxes%latent(i,j) = 0.0 * G%mask2dT(i,j) + fluxes%sens(i,j) = CS%Heat(i,j) * G%mask2dT(i,j) + fluxes%sw(i,j) = CS%Solar(i,j) * G%mask2dT(i,j) enddo ; enddo else ! This is the buoyancy only mode. do j=js,je ; do i=is,ie diff --git a/config_src/solo_driver/MOM_surface_forcing.F90 b/config_src/solo_driver/MOM_surface_forcing.F90 index 54a46a8e73..c5a924913d 100644 --- a/config_src/solo_driver/MOM_surface_forcing.F90 +++ b/config_src/solo_driver/MOM_surface_forcing.F90 @@ -882,11 +882,11 @@ subroutine buoyancy_forcing_from_files(sfc_state, fluxes, day, dt, G, US, CS) case (365) ; time_lev = time_lev_daily case default ; time_lev = 1 end select - call MOM_read_data(CS%shortwave_file, CS%SW_var, fluxes%sw(:,:), & - G%Domain, timelevel=time_lev) + call MOM_read_data(CS%shortwave_file, CS%SW_var, fluxes%sw(:,:), G%Domain, & + timelevel=time_lev, scale=US%W_m2_to_QRZ_T) if (CS%archaic_OMIP_file) then - call MOM_read_data(CS%shortwaveup_file, "swup_sfc", temp(:,:), & - G%Domain, timelevel=time_lev) + call MOM_read_data(CS%shortwaveup_file, "swup_sfc", temp(:,:), G%Domain, & + timelevel=time_lev, scale=US%W_m2_to_QRZ_T) do j=js,je ; do i=is,ie fluxes%sw(i,j) = fluxes%sw(i,j) - temp(i,j) enddo ; enddo @@ -1081,7 +1081,7 @@ subroutine buoyancy_forcing_from_data_override(sfc_state, fluxes, day, dt, G, US je_in = G%jec - G%jsd + 1 call data_override('OCN', 'lw', fluxes%lw(:,:), day, & - is_in=is_in, ie_in=ie_in, js_in=js_in, je_in=je_in) + is_in=is_in, ie_in=ie_in, js_in=js_in, je_in=je_in) ! scale=US%W_m2_to_QRZ_T if (US%QRZ_T_to_W_m2 /= 1.0) then ; do j=js,je ; do i=is,ie fluxes%lw(i,j) = fluxes%lw(i,j) * US%W_m2_to_QRZ_T enddo ; enddo ; endif @@ -1108,7 +1108,10 @@ subroutine buoyancy_forcing_from_data_override(sfc_state, fluxes, day, dt, G, US 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) + is_in=is_in, ie_in=ie_in, js_in=js_in, je_in=je_in) ! scale=US%W_m2_to_QRZ_T + if (US%QRZ_T_to_W_m2 /= 1.0) then ; do j=js,je ; do i=is,ie + fluxes%sw(i,j) = fluxes%sw(i,j) * US%W_m2_to_QRZ_T + enddo ; enddo ; endif call data_override('OCN', 'snow', fluxes%fprec(:,:), day, & is_in=is_in, ie_in=ie_in, js_in=js_in, je_in=je_in) ! scale=kg_m2_s_conversion diff --git a/src/core/MOM_forcing_type.F90 b/src/core/MOM_forcing_type.F90 index a0b563c861..c43199d430 100644 --- a/src/core/MOM_forcing_type.F90 +++ b/src/core/MOM_forcing_type.F90 @@ -59,13 +59,13 @@ module MOM_forcing_type real, pointer, dimension(:,:) :: & buoy => NULL() !< buoyancy flux [L2 T-3 ~> m2 s-3] - ! radiative heat fluxes into the ocean [W m-2] + ! radiative heat fluxes into the ocean [Q R Z T-1 ~> W m-2] real, pointer, dimension(:,:) :: & - sw => NULL(), & !< shortwave [W m-2] - sw_vis_dir => NULL(), & !< visible, direct shortwave [W m-2] - sw_vis_dif => NULL(), & !< visible, diffuse shortwave [W m-2] - sw_nir_dir => NULL(), & !< near-IR, direct shortwave [W m-2] - sw_nir_dif => NULL(), & !< near-IR, diffuse shortwave [W m-2] + sw => NULL(), & !< shortwave [Q R Z T-1 ~> W m-2] + sw_vis_dir => NULL(), & !< visible, direct shortwave [Q R Z T-1 ~> W m-2] + sw_vis_dif => NULL(), & !< visible, diffuse shortwave [Q R Z T-1 ~> W m-2] + sw_nir_dir => NULL(), & !< near-IR, direct shortwave [Q R Z T-1 ~> W m-2] + sw_nir_dif => NULL(), & !< near-IR, diffuse shortwave [Q R Z T-1 ~> W m-2] lw => NULL() !< longwave [Q R Z T-1 ~> W m-2] (typically negative) ! turbulent heat fluxes into the ocean [Q R Z T-1 ~> W m-2] @@ -584,19 +584,19 @@ subroutine extractFluxes1d(G, GV, US, fluxes, optics, nsw, j, dt_in_T, & ! CIME provides heat flux from snow&ice melt (seaice_melt_heat), so this is added below if (associated(fluxes%seaice_melt_heat)) then - net_heat(i) = scale * dt_in_T * W_m2_to_H_T * & - ( fluxes%sw(i,j) + US%QRZ_T_to_W_m2*(((fluxes%lw(i,j) + fluxes%latent(i,j)) + fluxes%sens(i,j)) + & + net_heat(i) = scale * dt_in_T * W_m2_to_H_T * US%QRZ_T_to_W_m2 * & + ( fluxes%sw(i,j) + (((fluxes%lw(i,j) + fluxes%latent(i,j)) + fluxes%sens(i,j)) + & fluxes%seaice_melt_heat(i,j)) ) !Repeats above code w/ dt=1. for legacy reason - if (do_NHR) net_heat_rate(i) = scale * W_m2_to_H_T * & - ( fluxes%sw(i,j) + US%QRZ_T_to_W_m2*(((fluxes%lw(i,j) + fluxes%latent(i,j)) + fluxes%sens(i,j)) + & + if (do_NHR) net_heat_rate(i) = scale * W_m2_to_H_T * US%QRZ_T_to_W_m2 * & + ( fluxes%sw(i,j) + (((fluxes%lw(i,j) + fluxes%latent(i,j)) + fluxes%sens(i,j)) + & fluxes%seaice_melt_heat(i,j))) else - net_heat(i) = scale * dt_in_T * W_m2_to_H_T * & - ( fluxes%sw(i,j) + US%QRZ_T_to_W_m2*((fluxes%lw(i,j) + fluxes%latent(i,j)) + fluxes%sens(i,j)) ) + net_heat(i) = scale * dt_in_T * W_m2_to_H_T * US%QRZ_T_to_W_m2 * & + ( fluxes%sw(i,j) + ((fluxes%lw(i,j) + fluxes%latent(i,j)) + fluxes%sens(i,j)) ) !Repeats above code w/ dt=1. for legacy reason - if (do_NHR) net_heat_rate(i) = scale * W_m2_to_H_T * & - ( fluxes%sw(i,j) + US%QRZ_T_to_W_m2*((fluxes%lw(i,j) + fluxes%latent(i,j)) + fluxes%sens(i,j)) ) + if (do_NHR) net_heat_rate(i) = scale * W_m2_to_H_T * US%QRZ_T_to_W_m2 * & + ( fluxes%sw(i,j) + ((fluxes%lw(i,j) + fluxes%latent(i,j)) + fluxes%sens(i,j)) ) endif ! Add heat flux from surface damping (restoring) (K * H) or flux adjustments. @@ -656,12 +656,12 @@ subroutine extractFluxes1d(G, GV, US, fluxes, optics, nsw, j, dt_in_T, & ! endif if (fluxes%num_msg < fluxes%max_msg) then - if (Pen_SW_tot(i) > 1.000001 * W_m2_to_H_T*scale*dt_in_T*fluxes%sw(i,j)) then + if (Pen_SW_tot(i) > 1.000001 * W_m2_to_H_T*US%QRZ_T_to_W_m2*scale*dt_in_T*fluxes%sw(i,j)) then fluxes%num_msg = fluxes%num_msg + 1 write(mesg,'("Penetrating shortwave of ",1pe17.10, & &" exceeds total shortwave of ",1pe17.10,& &" at ",1pg11.4,"E, "1pg11.4,"N.")') & - Pen_SW_tot(i),W_m2_to_H_T*scale*dt_in_T * fluxes%sw(i,j),& + Pen_SW_tot(i),W_m2_to_H_T*US%QRZ_T_to_W_m2*scale*dt_in_T * fluxes%sw(i,j),& G%geoLonT(i,j),G%geoLatT(i,j) call MOM_error(WARNING,mesg) endif @@ -675,7 +675,7 @@ subroutine extractFluxes1d(G, GV, US, fluxes, optics, nsw, j, dt_in_T, & ! diagnose non-downwelling SW if (present(nonPenSW)) then - nonPenSW(i) = scale * dt_in_T * W_m2_to_H_T * fluxes%sw(i,j) - Pen_SW_tot(i) + nonPenSW(i) = scale * dt_in_T * W_m2_to_H_T * US%QRZ_T_to_W_m2*fluxes%sw(i,j) - Pen_SW_tot(i) endif ! Salt fluxes @@ -1029,19 +1029,19 @@ subroutine MOM_forcing_chksum(mesg, fluxes, G, US, haloshift) ! counts, there must be no redundant points, so all variables use is..ie ! and js...je as their extent. if (associated(fluxes%ustar)) & - call hchksum(fluxes%ustar, mesg//" fluxes%ustar",G%HI, haloshift=hshift, scale=US%Z_to_m*US%s_to_T) + call hchksum(fluxes%ustar, mesg//" fluxes%ustar", G%HI, haloshift=hshift, scale=US%Z_to_m*US%s_to_T) if (associated(fluxes%buoy)) & - call hchksum(fluxes%buoy, mesg//" fluxes%buoy ",G%HI, haloshift=hshift, scale=US%L_to_m**2*US%s_to_T**3) + call hchksum(fluxes%buoy, mesg//" fluxes%buoy ", G%HI, haloshift=hshift, scale=US%L_to_m**2*US%s_to_T**3) if (associated(fluxes%sw)) & - call hchksum(fluxes%sw, mesg//" fluxes%sw",G%HI,haloshift=hshift) + call hchksum(fluxes%sw, mesg//" fluxes%sw",G%HI, haloshift=hshift, scale=US%QRZ_T_to_W_m2) if (associated(fluxes%sw_vis_dir)) & - call hchksum(fluxes%sw_vis_dir, mesg//" fluxes%sw_vis_dir",G%HI,haloshift=hshift) + call hchksum(fluxes%sw_vis_dir, mesg//" fluxes%sw_vis_dir", G%HI, haloshift=hshift, scale=US%QRZ_T_to_W_m2) if (associated(fluxes%sw_vis_dif)) & - call hchksum(fluxes%sw_vis_dif, mesg//" fluxes%sw_vis_dif",G%HI,haloshift=hshift) + call hchksum(fluxes%sw_vis_dif, mesg//" fluxes%sw_vis_dif", G%HI, haloshift=hshift, scale=US%QRZ_T_to_W_m2) if (associated(fluxes%sw_nir_dir)) & - call hchksum(fluxes%sw_nir_dir, mesg//" fluxes%sw_nir_dir",G%HI,haloshift=hshift) + call hchksum(fluxes%sw_nir_dir, mesg//" fluxes%sw_nir_dir", G%HI, haloshift=hshift, scale=US%QRZ_T_to_W_m2) if (associated(fluxes%sw_nir_dif)) & - call hchksum(fluxes%sw_nir_dif, mesg//" fluxes%sw_nir_dif",G%HI,haloshift=hshift) + call hchksum(fluxes%sw_nir_dif, mesg//" fluxes%sw_nir_dif", G%HI, haloshift=hshift, scale=US%QRZ_T_to_W_m2) if (associated(fluxes%lw)) & call hchksum(fluxes%lw, mesg//" fluxes%lw", G%HI, haloshift=hshift, scale=US%QRZ_T_to_W_m2) if (associated(fluxes%latent)) & @@ -1539,17 +1539,17 @@ subroutine register_forcing_type_diags(Time, diag, US, use_temperature, handles, cmor_long_name='Surface ocean heat flux from SW+LW+latent+sensible+masstransfer+frazil+seaice_melt_heat') handles%id_sw = register_diag_field('ocean_model', 'SW', diag%axesT1, Time, & - 'Shortwave radiation flux into ocean', 'W m-2', & + 'Shortwave radiation flux into ocean', 'W m-2', conversion=US%QRZ_T_to_W_m2, & standard_name='net_downward_shortwave_flux_at_sea_water_surface', & cmor_field_name='rsntds', & cmor_standard_name='net_downward_shortwave_flux_at_sea_water_surface', & cmor_long_name='Net Downward Shortwave Radiation at Sea Water Surface') handles%id_sw_vis = register_diag_field('ocean_model', 'sw_vis', diag%axesT1, Time, & 'Shortwave radiation direct and diffuse flux into the ocean in the visible band', & - 'W m-2') + 'W m-2', conversion=US%QRZ_T_to_W_m2) handles%id_sw_nir = register_diag_field('ocean_model', 'sw_nir', diag%axesT1, Time, & 'Shortwave radiation direct and diffuse flux into the ocean in the near-infrared band', & - 'W m-2') + 'W m-2', conversion=US%QRZ_T_to_W_m2) handles%id_LwLatSens = register_diag_field('ocean_model', 'LwLatSens', diag%axesT1, Time, & 'Combined longwave, latent, and sensible heating at ocean surface', 'W m-2') @@ -2518,7 +2518,7 @@ subroutine forcing_diagnostics(fluxes, sfc_state, G, US, time_end, diag, handles if (associated(fluxes%LW)) res(i,j) = res(i,j) + US%QRZ_T_to_W_m2*fluxes%lw(i,j) if (associated(fluxes%latent)) res(i,j) = res(i,j) + US%QRZ_T_to_W_m2*fluxes%latent(i,j) if (associated(fluxes%sens)) res(i,j) = res(i,j) + US%QRZ_T_to_W_m2*fluxes%sens(i,j) - if (associated(fluxes%SW)) res(i,j) = res(i,j) + fluxes%SW(i,j) + if (associated(fluxes%SW)) res(i,j) = res(i,j) + US%QRZ_T_to_W_m2*fluxes%sw(i,j) if (associated(fluxes%seaice_melt_heat)) res(i,j) = res(i,j) + US%QRZ_T_to_W_m2*fluxes%seaice_melt_heat(i,j) enddo ; enddo if (handles%id_net_heat_coupler > 0) call post_data(handles%id_net_heat_coupler, res, diag) @@ -2539,7 +2539,7 @@ subroutine forcing_diagnostics(fluxes, sfc_state, G, US, time_end, diag, handles if (associated(fluxes%LW)) res(i,j) = res(i,j) + US%QRZ_T_to_W_m2*fluxes%lw(i,j) if (associated(fluxes%latent)) res(i,j) = res(i,j) + US%QRZ_T_to_W_m2*fluxes%latent(i,j) if (associated(fluxes%sens)) res(i,j) = res(i,j) + US%QRZ_T_to_W_m2*fluxes%sens(i,j) - if (associated(fluxes%SW)) res(i,j) = res(i,j) + fluxes%SW(i,j) + if (associated(fluxes%SW)) res(i,j) = res(i,j) + US%QRZ_T_to_W_m2*fluxes%sw(i,j) if (associated(fluxes%seaice_melt_heat)) res(i,j) = res(i,j) + US%QRZ_T_to_W_m2*fluxes%seaice_melt_heat(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 @@ -2658,11 +2658,11 @@ subroutine forcing_diagnostics(fluxes, sfc_state, G, US, time_end, diag, handles 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 - total_transport = global_area_integral(fluxes%sw,G) + total_transport = global_area_integral(fluxes%sw, G, scale=US%QRZ_T_to_W_m2) call post_data(handles%id_total_sw, total_transport, diag) endif if ((handles%id_sw_ga > 0) .and. associated(fluxes%sw)) then - ave_flux = global_area_mean(fluxes%sw,G) + ave_flux = global_area_mean(fluxes%sw, G, scale=US%QRZ_T_to_W_m2) call post_data(handles%id_sw_ga, ave_flux, diag) endif diff --git a/src/diagnostics/MOM_sum_output.F90 b/src/diagnostics/MOM_sum_output.F90 index 7b56bc5705..f094fcc6fc 100644 --- a/src/diagnostics/MOM_sum_output.F90 +++ b/src/diagnostics/MOM_sum_output.F90 @@ -1000,8 +1000,8 @@ subroutine accumulate_net_input(fluxes, sfc_state, tv, dt, G, US, CS) if (CS%use_temperature) then if (associated(fluxes%sw)) then ; do j=js,je ; do i=is,ie - heat_in(i,j) = heat_in(i,j) + dt*US%T_to_s*US%L_to_m**2*G%areaT(i,j) * (fluxes%sw(i,j) + & - US%QRZ_T_to_W_m2*(fluxes%lw(i,j) + (fluxes%latent(i,j) + fluxes%sens(i,j)))) + heat_in(i,j) = heat_in(i,j) + dt*US%T_to_s*US%L_to_m**2*US%QRZ_T_to_W_m2*G%areaT(i,j) * (fluxes%sw(i,j) + & + (fluxes%lw(i,j) + (fluxes%latent(i,j) + fluxes%sens(i,j)))) enddo ; enddo ; endif if (associated(fluxes%seaice_melt_heat)) then ; do j=js,je ; do i=is,ie diff --git a/src/parameterizations/vertical/MOM_diabatic_aux.F90 b/src/parameterizations/vertical/MOM_diabatic_aux.F90 index 95cc752ae3..e74de9a57f 100644 --- a/src/parameterizations/vertical/MOM_diabatic_aux.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_aux.F90 @@ -655,13 +655,14 @@ subroutine find_uv_at_h(u, v, h, u_h, v_h, G, GV, US, ea, eb) end subroutine find_uv_at_h -subroutine set_pen_shortwave(optics, fluxes, G, GV, CS, opacity_CSp, tracer_flow_CSp) +subroutine set_pen_shortwave(optics, fluxes, G, GV, US, CS, opacity_CSp, tracer_flow_CSp) type(optics_type), pointer :: optics !< An optics structure that has will contain !! information about shortwave fluxes and absorption. type(forcing), intent(inout) :: fluxes !< points to 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(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(diabatic_aux_CS), pointer :: CS !< Control structure for diabatic_aux type(opacity_CS), pointer :: opacity_CSp !< The control structure for the opacity module. type(tracer_flow_control_CS), pointer :: tracer_flow_CSp !< A pointer to the control structure @@ -693,7 +694,7 @@ subroutine set_pen_shortwave(optics, fluxes, G, GV, CS, opacity_CSp, tracer_flow if (CS%id_chl > 0) call post_data(CS%id_chl, chl_2d, CS%diag) call set_opacity(optics, fluxes%sw, fluxes%sw_vis_dir, fluxes%sw_vis_dif, & - fluxes%sw_nir_dir, fluxes%sw_nir_dif, G, GV, opacity_CSp, chl_2d=chl_2d) + fluxes%sw_nir_dir, fluxes%sw_nir_dif, G, GV, US, opacity_CSp, chl_2d=chl_2d) else if (.not.associated(tracer_flow_CSp)) call MOM_error(FATAL, & "The tracer flow control structure must be associated when the model sets "//& @@ -703,11 +704,11 @@ subroutine set_pen_shortwave(optics, fluxes, G, GV, CS, opacity_CSp, tracer_flow if (CS%id_chl > 0) call post_data(CS%id_chl, chl_3d(:,:,1), CS%diag) call set_opacity(optics, fluxes%sw, fluxes%sw_vis_dir, fluxes%sw_vis_dif, & - fluxes%sw_nir_dir, fluxes%sw_nir_dif, G, GV, opacity_CSp, chl_3d=chl_3d) + fluxes%sw_nir_dir, fluxes%sw_nir_dif, G, GV, US, opacity_CSp, chl_3d=chl_3d) endif else call set_opacity(optics, fluxes%sw, fluxes%sw_vis_dir, fluxes%sw_vis_dif, & - fluxes%sw_nir_dir, fluxes%sw_nir_dif, G, GV, opacity_CSp) + fluxes%sw_nir_dir, fluxes%sw_nir_dif, G, GV, US, opacity_CSp) endif end subroutine set_pen_shortwave diff --git a/src/parameterizations/vertical/MOM_diabatic_driver.F90 b/src/parameterizations/vertical/MOM_diabatic_driver.F90 index 5b11e6ed04..a19402eded 100644 --- a/src/parameterizations/vertical/MOM_diabatic_driver.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_driver.F90 @@ -581,7 +581,7 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Tim ! It will need to be modified later to include information about the ! biological properties and layer thicknesses. if (associated(CS%optics)) & - call set_pen_shortwave(CS%optics, fluxes, G, GV, CS%diabatic_aux_CSp, CS%opacity_CSp, CS%tracer_flow_CSp) + call set_pen_shortwave(CS%optics, fluxes, G, GV, US, CS%diabatic_aux_CSp, CS%opacity_CSp, CS%tracer_flow_CSp) if (CS%debug) call MOM_state_chksum("before find_uv_at_h", u, v, h, G, GV, US, haloshift=0) @@ -1366,7 +1366,7 @@ subroutine diabatic_ALE(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, ! It will need to be modified later to include information about the ! biological properties and layer thicknesses. if (associated(CS%optics)) & - call set_pen_shortwave(CS%optics, fluxes, G, GV, CS%diabatic_aux_CSp, CS%opacity_CSp, CS%tracer_flow_CSp) + call set_pen_shortwave(CS%optics, fluxes, G, GV, US, CS%diabatic_aux_CSp, CS%opacity_CSp, CS%tracer_flow_CSp) if (CS%debug) call MOM_state_chksum("before find_uv_at_h", u, v, h, G, GV, US, haloshift=0) @@ -2057,7 +2057,7 @@ subroutine layered_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_e ! It will need to be modified later to include information about the ! biological properties and layer thicknesses. if (associated(CS%optics)) & - call set_pen_shortwave(CS%optics, fluxes, G, GV, CS%diabatic_aux_CSp, CS%opacity_CSp, CS%tracer_flow_CSp) + call set_pen_shortwave(CS%optics, fluxes, G, GV, US, CS%diabatic_aux_CSp, CS%opacity_CSp, CS%tracer_flow_CSp) if (CS%bulkmixedlayer) then if (CS%debug) call MOM_forcing_chksum("Before mixedlayer", fluxes, G, US, haloshift=0) diff --git a/src/parameterizations/vertical/MOM_entrain_diffusive.F90 b/src/parameterizations/vertical/MOM_entrain_diffusive.F90 index d7985d1f1b..76aa99ccc6 100644 --- a/src/parameterizations/vertical/MOM_entrain_diffusive.F90 +++ b/src/parameterizations/vertical/MOM_entrain_diffusive.F90 @@ -190,7 +190,7 @@ subroutine entrainment_diffusive(h, tv, fluxes, dt, G, GV, US, CS, ea, eb, & real :: h_avail ! The thickness that is available for entrainment [H ~> m or kg m-2]. real :: dS_kb_eff ! The value of dS_kb after limiting is taken into account. real :: Rho_cor ! The depth-integrated potential density anomaly that - ! needs to be corrected for [H kg m-3 ~> kg m-2 or kg2 m-5]. + ! needs to be corrected for [H R ~> kg m-2 or kg2 m-5]. real :: ea_cor ! The corrective adjustment to eakb [H ~> m or kg m-2]. real :: h1 ! The layer thickness after entrainment through the ! interface below is taken into account [H ~> m or kg m-2]. diff --git a/src/parameterizations/vertical/MOM_opacity.F90 b/src/parameterizations/vertical/MOM_opacity.F90 index 18b01223ff..8a25ee9ee6 100644 --- a/src/parameterizations/vertical/MOM_opacity.F90 +++ b/src/parameterizations/vertical/MOM_opacity.F90 @@ -89,20 +89,20 @@ module MOM_opacity !> This sets the opacity of sea water based based on one of several different schemes. subroutine set_opacity(optics, sw_total, sw_vis_dir, sw_vis_dif, sw_nir_dir, sw_nir_dif, & - G, GV, CS, chl_2d, chl_3d) + G, GV, US, CS, chl_2d, chl_3d) type(optics_type), intent(inout) :: optics !< An optics structure that has values !! set based on the opacities. - real, dimension(:,:), pointer :: sw_total !< Total shortwave flux into the ocean [W m-2] - real, dimension(:,:), pointer :: sw_vis_dir !< Visible, direct shortwave into the ocean [W m-2] - real, dimension(:,:), pointer :: sw_vis_dif !< Visible, diffuse shortwave into the ocean [W m-2] - real, dimension(:,:), pointer :: sw_nir_dir !< Near-IR, direct shortwave into the ocean [W m-2] - real, dimension(:,:), pointer :: sw_nir_dif !< Near-IR, diffuse shortwave into the ocean [W m-2] + real, dimension(:,:), pointer :: sw_total !< Total shortwave flux into the ocean [Q R Z T-1 ~> W m-2] + real, dimension(:,:), pointer :: sw_vis_dir !< Visible, direct shortwave into the ocean [Q R Z T-1 ~> W m-2] + real, dimension(:,:), pointer :: sw_vis_dif !< Visible, diffuse shortwave into the ocean [Q R Z T-1 ~> W m-2] + real, dimension(:,:), pointer :: sw_nir_dir !< Near-IR, direct shortwave into the ocean [Q R Z T-1 ~> W m-2] + real, dimension(:,:), pointer :: sw_nir_dif !< Near-IR, diffuse shortwave into the ocean [Q R Z T-1 ~> W m-2] 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(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(opacity_CS), pointer :: CS !< The control structure earlier set up by opacity_init. real, dimension(SZI_(G),SZJ_(G)), & - optional, intent(in) :: chl_2d !< Vertically uniform chlorophyll-A concentractions[mg m-3] + optional, intent(in) :: chl_2d !< Vertically uniform chlorophyll-A concentractions [mg m-3] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & optional, intent(in) :: chl_3d !< The chlorophyll-A concentractions of each layer [mg m-3] @@ -124,7 +124,7 @@ subroutine set_opacity(optics, sw_total, sw_vis_dir, sw_vis_dif, sw_nir_dir, sw_ if (present(chl_2d) .or. present(chl_3d)) then ! The optical properties are based on cholophyll concentrations. call opacity_from_chl(optics, sw_total, sw_vis_dir, sw_vis_dif, sw_nir_dir, sw_nir_dif, & - G, GV, CS, chl_2d, chl_3d) + G, GV, US, CS, chl_2d, chl_3d) else ! Use sw e-folding scale set by MOM_input if (optics%nbands <= 1) then ; Inv_nbands = 1.0 else ; Inv_nbands = 1.0 / real(optics%nbands) ; endif @@ -147,8 +147,8 @@ subroutine set_opacity(optics, sw_total, sw_vis_dir, sw_vis_dif, sw_nir_dir, sw_ else !$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) * sw_total(i,j) - optics%sw_pen_band(2,i,j) = (1.-CS%SW_1st_EXP_RATIO) * sw_total(i,j) + optics%sw_pen_band(1,i,j) = (CS%SW_1st_EXP_RATIO) * US%QRZ_T_to_W_m2*sw_total(i,j) + optics%sw_pen_band(2,i,j) = (1.-CS%SW_1st_EXP_RATIO) * US%QRZ_T_to_W_m2*sw_total(i,j) enddo ; enddo endif else @@ -163,7 +163,7 @@ subroutine set_opacity(optics, sw_total, sw_vis_dir, sw_vis_dif, sw_nir_dir, sw_ else !$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 * sw_total(i,j) + optics%sw_pen_band(n,i,j) = CS%pen_SW_frac * Inv_nbands * US%QRZ_T_to_W_m2*sw_total(i,j) enddo ; enddo ; enddo endif endif @@ -218,16 +218,17 @@ end subroutine set_opacity !> This sets the "blue" band opacity based on chloophyll A concencentrations !! The red portion is lumped into the net heating at the surface. subroutine opacity_from_chl(optics, sw_total, sw_vis_dir, sw_vis_dif, sw_nir_dir, sw_nir_dif, & - G, GV, CS, chl_2d, chl_3d) + G, GV, US, CS, chl_2d, chl_3d) type(optics_type), intent(inout) :: optics !< An optics structure that has values !! set based on the opacities. - real, dimension(:,:), pointer :: sw_total !< Total shortwave flux into the ocean [W m-2] - real, dimension(:,:), pointer :: sw_vis_dir !< Visible, direct shortwave into the ocean [W m-2] - real, dimension(:,:), pointer :: sw_vis_dif !< Visible, diffuse shortwave into the ocean [W m-2] - real, dimension(:,:), pointer :: sw_nir_dir !< Near-IR, direct shortwave into the ocean [W m-2] - real, dimension(:,:), pointer :: sw_nir_dif !< Near-IR, diffuse shortwave into the ocean [W m-2] + real, dimension(:,:), pointer :: sw_total !< Total shortwave flux into the ocean [Q R Z T-1 ~> W m-2] + real, dimension(:,:), pointer :: sw_vis_dir !< Visible, direct shortwave into the ocean [Q R Z T-1 ~> W m-2] + real, dimension(:,:), pointer :: sw_vis_dif !< Visible, diffuse shortwave into the ocean [Q R Z T-1 ~> W m-2] + real, dimension(:,:), pointer :: sw_nir_dir !< Near-IR, direct shortwave into the ocean [Q R Z T-1 ~> W m-2] + real, dimension(:,:), pointer :: sw_nir_dif !< Near-IR, diffuse shortwave into the ocean [Q R Z T-1 ~> W m-2] type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(opacity_CS), pointer :: CS !< The control structure. real, dimension(SZI_(G),SZJ_(G)), & optional, intent(in) :: chl_2d !< Vertically uniform chlorophyll-A concentractions [mg m-3] @@ -240,11 +241,11 @@ subroutine opacity_from_chl(optics, sw_total, sw_vis_dir, sw_vis_dif, sw_nir_dir real :: Inv_nbands_nir ! The inverse of the number of bands of penetrating ! near-infrafed radiation. real :: SW_pen_tot ! The sum across the bands of the penetrating - ! shortwave radiation [W m-2]. + ! shortwave radiation [Q R Z T-1 ~> W m-2]. real :: SW_vis_tot ! The sum across the visible bands of shortwave - ! radiation [W m-2]. + ! radiation [Q R Z T-1 ~> W m-2]. real :: SW_nir_tot ! The sum across the near infrared bands of shortwave - ! radiation [W m-2]. + ! radiation [Q R Z T-1 ~> W m-2]. type(time_type) :: day character(len=128) :: mesg integer :: i, j, k, n, is, ie, js, je, nz, nbands @@ -321,13 +322,13 @@ subroutine opacity_from_chl(optics, sw_total, sw_vis_dir, sw_vis_dif, sw_nir_dir endif ! Band 1 is Manizza blue. - optics%sw_pen_band(1,i,j) = CS%blue_frac*SW_vis_tot + optics%sw_pen_band(1,i,j) = CS%blue_frac*US%QRZ_T_to_W_m2*sw_vis_tot ! Band 2 (if used) is Manizza red. if (nbands > 1) & - optics%sw_pen_band(2,i,j) = (1.0-CS%blue_frac)*SW_vis_tot + optics%sw_pen_band(2,i,j) = (1.0-CS%blue_frac)*US%QRZ_T_to_W_m2*sw_vis_tot ! All remaining bands are NIR, for lack of something better to do. do n=3,nbands - optics%sw_pen_band(n,i,j) = Inv_nbands_nir * SW_nir_tot + optics%sw_pen_band(n,i,j) = Inv_nbands_nir * US%QRZ_T_to_W_m2*sw_nir_tot enddo enddo ; enddo case (MOREL_88) @@ -335,15 +336,13 @@ subroutine opacity_from_chl(optics, sw_total, sw_vis_dir, sw_vis_dif, sw_nir_dir do j=js,je ; do i=is,ie SW_pen_tot = 0.0 if (G%mask2dT(i,j) > 0.5) then ; if (multiband_vis_input) then - SW_pen_tot = SW_pen_frac_morel(chl_data(i,j)) * & - (sw_vis_dir(i,j) + sw_vis_dif(i,j)) + SW_pen_tot = SW_pen_frac_morel(chl_data(i,j)) * (sw_vis_dir(i,j) + sw_vis_dif(i,j)) else - SW_pen_tot = SW_pen_frac_morel(chl_data(i,j)) * & - 0.5*sw_total(i,j) + SW_pen_tot = SW_pen_frac_morel(chl_data(i,j)) * 0.5*sw_total(i,j) endif ; endif do n=1,nbands - optics%sw_pen_band(n,i,j) = Inv_nbands*SW_pen_tot + optics%sw_pen_band(n,i,j) = Inv_nbands*US%QRZ_T_to_W_m2*sw_pen_tot enddo enddo ; enddo case default @@ -721,7 +720,6 @@ subroutine absorbRemainingSW(G, GV, US, h, opacity_band, nsw, optics, j, dt, H_l endif enddo ; enddo ! i & k loops - ! if (.not.absorbAllSW .and. .not.adjustAbsorptionProfile) return ! Unless modified, there is no temperature change due to fluxes from the bottom. diff --git a/src/tracer/MOM_offline_aux.F90 b/src/tracer/MOM_offline_aux.F90 index 0900598589..21db2cfff4 100644 --- a/src/tracer/MOM_offline_aux.F90 +++ b/src/tracer/MOM_offline_aux.F90 @@ -733,15 +733,15 @@ subroutine update_offline_from_files(G, GV, nk_input, mean_file, sum_file, snap_ ! Need to double check, but set_opacity seems to only need the sum of the diffuse and ! direct fluxes in the visible and near-infrared bands. For convenience, we store the ! sum of the direct and diffuse fluxes in the 'dir' field and set the 'dif' fields to zero - call MOM_read_data(mean_file,'sw_vis',fluxes%sw_vis_dir, G%Domain, & - timelevel=ridx_sum) - call MOM_read_data(mean_file,'sw_nir',fluxes%sw_nir_dir, G%Domain, & - timelevel=ridx_sum) + call MOM_read_data(mean_file,'sw_vis', fluxes%sw_vis_dir, G%Domain, & + timelevel=ridx_sum, scale=G%US%W_m2_to_QRZ_T) + call MOM_read_data(mean_file,'sw_nir', fluxes%sw_nir_dir, G%Domain, & + timelevel=ridx_sum, scale=G%US%W_m2_to_QRZ_T) 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 = fluxes%sw_vis_dir + fluxes%sw_vis_dif + fluxes%sw_nir_dir + fluxes%sw_nir_dif + 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 diff --git a/src/tracer/MOM_offline_main.F90 b/src/tracer/MOM_offline_main.F90 index 7da25d6841..3dd5a9ab2b 100644 --- a/src/tracer/MOM_offline_main.F90 +++ b/src/tracer/MOM_offline_main.F90 @@ -663,7 +663,8 @@ subroutine offline_diabatic_ale(fluxes, Time_start, Time_end, CS, h_pre, eatr, e real, dimension(SZI_(CS%G),SZJ_(CS%G),SZK_(CS%G)), & intent(inout) :: ebtr !< Entrainment from layer below [H ~> m or kg m-2] - real, dimension(SZI_(CS%G),SZJ_(CS%G)) :: sw, sw_vis, sw_nir !< Save old value of shortwave radiation + real, dimension(SZI_(CS%G),SZJ_(CS%G)) :: & + sw, sw_vis, sw_nir !< Save old values of shortwave radiation [Q R Z T-1 ~> W m-2] real :: hval integer :: i,j,k integer :: is, ie, js, je, nz @@ -728,7 +729,8 @@ subroutine offline_diabatic_ale(fluxes, Time_start, Time_end, CS, h_pre, eatr, e endif if (associated(CS%optics)) & - call set_pen_shortwave(CS%optics, fluxes, CS%G, CS%GV, CS%diabatic_aux_CSp, CS%opacity_CSp, CS%tracer_flow_CSp) + call set_pen_shortwave(CS%optics, fluxes, CS%G, CS%GV, CS%US, CS%diabatic_aux_CSp, & + CS%opacity_CSp, CS%tracer_flow_CSp) ! Note that tracerBoundaryFluxesInOut within this subroutine should NOT be called ! as the freshwater fluxes have already been accounted for diff --git a/src/user/SCM_CVMix_tests.F90 b/src/user/SCM_CVMix_tests.F90 index f9ba5bc724..be12f75c38 100644 --- a/src/user/SCM_CVMix_tests.F90 +++ b/src/user/SCM_CVMix_tests.F90 @@ -40,7 +40,7 @@ module SCM_CVMix_tests real :: tau_y !< (Constant) Wind stress, Y [Pa] real :: surf_HF !< (Constant) Heat flux [degC Z T-1 ~> m degC s-1] real :: surf_evap !< (Constant) Evaporation rate [Z T-1 ~> m s-1] - real :: Max_sw !< maximum of diurnal sw radiation [m degC s-1] + real :: Max_sw !< maximum of diurnal sw radiation [degC Z T-1 ~> degC m s-1] real :: Rho0 !< reference density [R ~> kg m-3] end type @@ -189,7 +189,7 @@ subroutine SCM_CVMix_tests_surface_forcing_init(Time, G, param_file, CS) call get_param(param_file, mdl, "SCM_DIURNAL_SW_MAX", & CS%Max_sw, "Maximum diurnal sw radiation "// & "used in the SCM CVMix test surface forcing.", & - units='m K/s', fail_if_missing=.true.) + units='m K/s', scale=US%m_to_Z*US%T_to_s, fail_if_missing=.true.) endif call get_param(param_file, mdl, "RHO_0", CS%Rho0, & "The mean ocean density used with BOUSSINESQ true to "//& @@ -274,12 +274,10 @@ subroutine SCM_CVMix_tests_buoyancy_forcing(state, fluxes, day, G, US, CS) if (CS%UseDiurnalSW) then do J=Jsq,Jeq ; do i=is,ie - ! Note CVMix test inputs give max sw rad in [m K/s] - ! therefore must convert to W/m2 by multiplying - ! by Rho0*Cp + ! Note CVMix test inputs give max sw rad in [m degC/s] + ! therefore must convert to W/m2 by multiplying by Rho0*Cp ! Note diurnal cycle peaks at Noon. - fluxes%sw(i,J) = CS%Max_sw * max(0.0,cos(2*PI* & - (time_type_to_real(DAY)/86400.-0.5))) * CS%RHO0 * US%Q_to_J_kg*fluxes%C_p + fluxes%sw(i,J) = CS%Max_sw * max(0.0, cos(2*PI*(time_type_to_real(DAY)/86400.0 - 0.5))) * CS%RHO0 * fluxes%C_p enddo ; enddo endif From 6e7d6f87da28f3b2e319412303d2ce2241215f35 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 14 Feb 2020 18:53:04 -0500 Subject: [PATCH 070/316] +Rescaled units of optics%sw_pen_band Rescaled the units of optics%sw_pen_band to [Q R Z T-1], along with several diagnostics, including correcting a large error in the diagnostic nonpenSW, and a rescaling of the output in the optional argument penSW_top returned from extract_optics_slice. Also added code under an answers_2018 flag specifying the order of sums of shortwave fluxes, since different compilers were using different orders. All solutions are bitwise identical. --- .../MOM_surface_forcing_gfdl.F90 | 10 ++-- src/core/MOM_forcing_type.F90 | 10 ++-- .../vertical/MOM_diabatic_aux.F90 | 30 ++++++------ .../vertical/MOM_opacity.F90 | 48 +++++++++---------- src/tracer/MOM_tracer_flow_control.F90 | 12 ++++- 5 files changed, 60 insertions(+), 50 deletions(-) diff --git a/config_src/coupled_driver/MOM_surface_forcing_gfdl.F90 b/config_src/coupled_driver/MOM_surface_forcing_gfdl.F90 index 384f7c2e4c..800a938064 100644 --- a/config_src/coupled_driver/MOM_surface_forcing_gfdl.F90 +++ b/config_src/coupled_driver/MOM_surface_forcing_gfdl.F90 @@ -532,9 +532,13 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, if (CS%check_no_land_fluxes) & call check_mask_val_consistency(IOB%sw_flux_nir_dif(i-i0,j-j0), G%mask2dT(i,j), i, j, 'sw_flux_nir_dif', G) endif - ! The parentheses here reproduce what most compilers do without any parentheses. - 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) + if (CS%answers_2018) then + 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 + 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)) + endif enddo ; enddo diff --git a/src/core/MOM_forcing_type.F90 b/src/core/MOM_forcing_type.F90 index c43199d430..1a9b1692c2 100644 --- a/src/core/MOM_forcing_type.F90 +++ b/src/core/MOM_forcing_type.F90 @@ -487,8 +487,8 @@ subroutine extractFluxes1d(G, GV, US, fluxes, optics, nsw, j, dt_in_T, & do k=2,nz ; do i=is,ie ; htot(i) = htot(i) + h(i,k) ; enddo ; enddo if (nsw >= 1) then - call extract_optics_slice(optics, j, G, GV, penSW_top=Pen_SW_bnd) !, penSW_scale=W_m2_to_H_T*dt_in_T - if (do_PSWBR) call extract_optics_slice(optics, j, G, GV, penSW_top=Pen_SW_bnd_rate) !, penSW_scale=W_m2_to_H_T + call extract_optics_slice(optics, j, G, GV, penSW_top=Pen_SW_bnd) + if (do_PSWBR) call extract_optics_slice(optics, j, G, GV, penSW_top=Pen_SW_bnd_rate) endif do i=is,ie @@ -499,8 +499,8 @@ subroutine extractFluxes1d(G, GV, US, fluxes, optics, nsw, j, dt_in_T, & ! (H=m for Bouss, H=kg/m2 for non-Bouss) Pen_sw_tot(i) = 0.0 if (nsw >= 1) then - do n=1,nsw - Pen_SW_bnd(n,i) = W_m2_to_H_T*scale*dt_in_T * max(0.0, Pen_SW_bnd(n,i)) + do n=1,nsw + Pen_SW_bnd(n,i) = US%QRZ_T_to_W_m2*W_m2_to_H_T*scale*dt_in_T * max(0.0, Pen_SW_bnd(n,i)) Pen_sw_tot(i) = Pen_sw_tot(i) + Pen_SW_bnd(n,i) enddo else @@ -511,7 +511,7 @@ subroutine extractFluxes1d(G, GV, US, fluxes, optics, nsw, j, dt_in_T, & pen_sw_tot_rate(i) = 0.0 if (nsw >= 1) then do n=1,nsw - Pen_SW_bnd_rate(n,i) = W_m2_to_H_T*scale * max(0.0, Pen_SW_bnd_rate(n,i)) + Pen_SW_bnd_rate(n,i) = US%QRZ_T_to_W_m2*W_m2_to_H_T*scale * max(0.0, Pen_SW_bnd_rate(n,i)) pen_sw_tot_rate(i) = pen_sw_tot_rate(i) + pen_sw_bnd_rate(n,i) enddo else diff --git a/src/parameterizations/vertical/MOM_diabatic_aux.F90 b/src/parameterizations/vertical/MOM_diabatic_aux.F90 index e74de9a57f..b8a0031686 100644 --- a/src/parameterizations/vertical/MOM_diabatic_aux.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_aux.F90 @@ -82,11 +82,11 @@ module MOM_diabatic_aux real, allocatable, dimension(:,:) :: createdH !< The amount of volume added in order to !! avoid grounding [H T-1 ~> m s-1] real, allocatable, dimension(:,:,:) :: penSW_diag !< Heating in a layer from convergence of - !! penetrative SW [W m-2] + !! penetrative SW [Q R Z T-1 ~> W m-2] real, allocatable, dimension(:,:,:) :: penSWflux_diag !< Penetrative SW flux at base of grid - !! layer [W m-2] + !! layer [Q R Z T-1 ~> W m-2] real, allocatable, dimension(:,:) :: nonpenSW_diag !< Non-downwelling SW radiation at ocean - !! surface [W m-2] + !! surface [Q R Z T-1 ~> W m-2] end type diabatic_aux_CS @@ -1305,14 +1305,13 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t tv%T(i,j,k) = T2d(i,k) enddo ; enddo - ! Diagnose heating [W m-2] applied to a grid cell from SW penetration + ! Diagnose heating [Q R Z T-1 ~> W m-2] 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 ! convergence of SW into a layer do k=1,nz ; do i=is,ie - CS%penSW_diag(i,j,k) = (T2d(i,k)-CS%penSW_diag(i,j,k))*h(i,j,k) * Idt * tv%C_p * & - US%Q_to_J_kg*GV%H_to_kg_m2*US%s_to_T + CS%penSW_diag(i,j,k) = (T2d(i,k)-CS%penSW_diag(i,j,k))*h(i,j,k) * Idt * tv%C_p * GV%H_to_RZ enddo ; enddo ! Perform a cumulative sum upwards from bottom to @@ -1332,7 +1331,7 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t ! Fill CS%nonpenSW_diag if (CS%id_nonpenSW_diag > 0) then do i=is,ie - CS%nonpenSW_diag(i,j) = nonpenSW(i) + CS%nonpenSW_diag(i,j) = nonpenSW(i) * Idt * tv%C_p * GV%H_to_RZ enddo endif @@ -1498,30 +1497,29 @@ subroutine diabatic_aux_init(Time, G, GV, US, param_file, diag, CS, useALEalgori ! diagnostic for heating of a grid cell from convergence of SW heat into the cell CS%id_penSW_diag = register_diag_field('ocean_model', 'rsdoabsorb', & diag%axesTL, Time, 'Convergence of Penetrative Shortwave Flux in Sea Water Layer',& - 'W m-2', standard_name='net_rate_of_absorption_of_shortwave_energy_in_ocean_layer',v_extensive=.true.) + 'W m-2', conversion=US%QRZ_T_to_W_m2, & + standard_name='net_rate_of_absorption_of_shortwave_energy_in_ocean_layer', v_extensive=.true.) ! diagnostic for penetrative SW heat flux at top interface of tracer cell (nz+1 interfaces) ! k=1 gives penetrative SW at surface; SW(k=nz+1)=0 (no penetration through rock). CS%id_penSWflux_diag = register_diag_field('ocean_model', 'rsdo', & diag%axesTi, Time, 'Downwelling Shortwave Flux in Sea Water at Grid Cell Upper Interface',& - 'W m-2', standard_name='downwelling_shortwave_flux_in_sea_water') + 'W m-2', conversion=US%QRZ_T_to_W_m2, standard_name='downwelling_shortwave_flux_in_sea_water') ! need both arrays for the SW diagnostics (one for flux, one for convergence) if (CS%id_penSW_diag>0 .or. CS%id_penSWflux_diag>0) then - allocate(CS%penSW_diag(isd:ied,jsd:jed,nz)) - CS%penSW_diag(:,:,:) = 0.0 - allocate(CS%penSWflux_diag(isd:ied,jsd:jed,nz+1)) - CS%penSWflux_diag(:,:,:) = 0.0 + allocate(CS%penSW_diag(isd:ied,jsd:jed,nz)) ; CS%penSW_diag(:,:,:) = 0.0 + allocate(CS%penSWflux_diag(isd:ied,jsd:jed,nz+1)) ; CS%penSWflux_diag(:,:,:) = 0.0 endif ! diagnostic for non-downwelling SW radiation (i.e., SW absorbed at ocean surface) CS%id_nonpenSW_diag = register_diag_field('ocean_model', 'nonpenSW', & diag%axesT1, Time, & 'Non-downwelling SW radiation (i.e., SW absorbed in ocean surface with LW,SENS,LAT)',& - 'W m-2', standard_name='nondownwelling_shortwave_flux_in_sea_water') + 'W m-2', conversion=US%QRZ_T_to_W_m2, & + standard_name='nondownwelling_shortwave_flux_in_sea_water') if (CS%id_nonpenSW_diag > 0) then - allocate(CS%nonpenSW_diag(isd:ied,jsd:jed)) - CS%nonpenSW_diag(:,:) = 0.0 + allocate(CS%nonpenSW_diag(isd:ied,jsd:jed)) ; CS%nonpenSW_diag(:,:) = 0.0 endif endif diff --git a/src/parameterizations/vertical/MOM_opacity.F90 b/src/parameterizations/vertical/MOM_opacity.F90 index 8a25ee9ee6..5ebeed6af6 100644 --- a/src/parameterizations/vertical/MOM_opacity.F90 +++ b/src/parameterizations/vertical/MOM_opacity.F90 @@ -28,8 +28,8 @@ module MOM_opacity real, pointer, dimension(:,:,:,:) :: opacity_band => NULL() !< SW optical depth per unit thickness [m-1] !! The number of radiation bands is most rapidly varying (first) index. - real, pointer, dimension(:,:,:) :: SW_pen_band => NULL() !< shortwave radiation [W m-2] at the surface - !! in each of the nbands bands that penetrates beyond the surface. + real, pointer, dimension(:,:,:) :: sw_pen_band => NULL() !< shortwave radiation [Q R Z T-1 ~> W m-2] + !! at the surface in each of the nbands bands that penetrates beyond the surface. !! The most rapidly varying dimension is the band. real, pointer, dimension(:) :: & @@ -115,7 +115,7 @@ subroutine set_opacity(optics, sw_total, sw_vis_dir, sw_vis_dif, sw_nir_dir, sw_ real :: tmp(SZI_(G),SZJ_(G),SZK_(GV)) ! A 3-d temporary array. real :: chl(SZI_(G),SZJ_(G),SZK_(GV)) ! The concentration of chlorophyll-A [mg m-3]. real :: Pen_SW_tot(SZI_(G),SZJ_(G)) ! The penetrating shortwave radiation - ! summed across all bands [W m-2]. + ! summed across all bands [Q R Z T-1 ~> W m-2]. is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke if (.not. associated(CS)) call MOM_error(FATAL, "set_opacity: "// & @@ -147,8 +147,8 @@ subroutine set_opacity(optics, sw_total, sw_vis_dir, sw_vis_dif, sw_nir_dir, sw_ else !$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) * US%QRZ_T_to_W_m2*sw_total(i,j) - optics%sw_pen_band(2,i,j) = (1.-CS%SW_1st_EXP_RATIO) * US%QRZ_T_to_W_m2*sw_total(i,j) + optics%sw_pen_band(1,i,j) = (CS%SW_1st_EXP_RATIO) * sw_total(i,j) + optics%sw_pen_band(2,i,j) = (1.-CS%SW_1st_EXP_RATIO) * sw_total(i,j) enddo ; enddo endif else @@ -163,7 +163,7 @@ subroutine set_opacity(optics, sw_total, sw_vis_dir, sw_vis_dif, sw_nir_dir, sw_ else !$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 * US%QRZ_T_to_W_m2*sw_total(i,j) + optics%sw_pen_band(n,i,j) = CS%pen_SW_frac * Inv_nbands * sw_total(i,j) enddo ; enddo ; enddo endif endif @@ -322,13 +322,13 @@ subroutine opacity_from_chl(optics, sw_total, sw_vis_dir, sw_vis_dif, sw_nir_dir endif ! Band 1 is Manizza blue. - optics%sw_pen_band(1,i,j) = CS%blue_frac*US%QRZ_T_to_W_m2*sw_vis_tot + optics%sw_pen_band(1,i,j) = CS%blue_frac*sw_vis_tot ! Band 2 (if used) is Manizza red. if (nbands > 1) & - optics%sw_pen_band(2,i,j) = (1.0-CS%blue_frac)*US%QRZ_T_to_W_m2*sw_vis_tot + optics%sw_pen_band(2,i,j) = (1.0-CS%blue_frac)*sw_vis_tot ! All remaining bands are NIR, for lack of something better to do. do n=3,nbands - optics%sw_pen_band(n,i,j) = Inv_nbands_nir * US%QRZ_T_to_W_m2*sw_nir_tot + optics%sw_pen_band(n,i,j) = Inv_nbands_nir * sw_nir_tot enddo enddo ; enddo case (MOREL_88) @@ -342,7 +342,7 @@ subroutine opacity_from_chl(optics, sw_total, sw_vis_dir, sw_vis_dif, sw_nir_dir endif ; endif do n=1,nbands - optics%sw_pen_band(n,i,j) = Inv_nbands*US%QRZ_T_to_W_m2*sw_pen_tot + optics%sw_pen_band(n,i,j) = Inv_nbands*sw_pen_tot enddo enddo ; enddo case default @@ -443,19 +443,19 @@ function opacity_manizza(chl_data) !> This subroutine returns a 2-d slice at constant j of fields from an optics_type, with the potential !! for rescaling these fields. subroutine extract_optics_slice(optics, j, G, GV, opacity, opacity_scale, penSW_top, penSW_scale) - type(optics_type), intent(in) :: optics !< An optics structure that has values of opacities - !! and shortwave fluxes. - integer, intent(in) :: j !< j-index to extract - 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(optics_type), intent(in) :: optics !< An optics structure that has values of opacities + !! and shortwave fluxes. + integer, intent(in) :: j !< j-index to extract + 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(max(optics%nbands,1),SZI_(G),SZK_(GV)), & - optional, intent(out) :: opacity !< The opacity in each band, i-point, and layer - real, optional, intent(in) :: opacity_scale !< A factor by which to rescale the opacity. + optional, intent(out) :: opacity !< The opacity in each band, i-point, and layer + real, optional, intent(in) :: opacity_scale !< A factor by which to rescale the opacity. real, dimension(max(optics%nbands,1),SZI_(G)), & - optional, intent(out) :: penSW_top !< The shortwave radiation [W m-2] at the surface - !! in each of the nbands bands that penetrates - !! beyond the surface skin layer. - real, optional, intent(in) :: penSW_scale !< A factor by which to rescale the shortwave flux. + optional, intent(out) :: penSW_top !< The shortwave radiation [Q R Z T-1 ~> W m-2] + !! at the surface in each of the nbands bands + !! that penetrates beyond the surface skin layer. + real, optional, intent(in) :: penSW_scale !< A factor by which to rescale the shortwave flux. ! Local variables real :: scale_opacity, scale_penSW ! Rescaling factors @@ -473,7 +473,7 @@ subroutine extract_optics_slice(optics, j, G, GV, opacity, opacity_scale, penSW_ if (present(penSW_top)) then ; do k=1,nz ; do i=is,ie do n=1,optics%nbands - penSW_top(n,i) = scale_penSW * optics%SW_pen_band(n,i,j) + penSW_top(n,i) = scale_penSW * optics%sw_pen_band(n,i,j) enddo enddo ; enddo ; endif @@ -1100,9 +1100,9 @@ subroutine opacity_init(Time, G, GV, US, param_file, diag, CS, optics) allocate(CS%id_opacity(optics%nbands)) ; CS%id_opacity(:) = -1 CS%id_sw_pen = register_diag_field('ocean_model', 'SW_pen', diag%axesT1, Time, & - 'Penetrating shortwave radiation flux into ocean', 'W m-2') + 'Penetrating shortwave radiation flux into ocean', 'W m-2', conversion=US%QRZ_T_to_W_m2) CS%id_sw_vis_pen = register_diag_field('ocean_model', 'SW_vis_pen', diag%axesT1, Time, & - 'Visible penetrating shortwave radiation flux into ocean', 'W m-2') + 'Visible penetrating shortwave radiation flux into ocean', 'W m-2', conversion=US%QRZ_T_to_W_m2) do n=1,optics%nbands write(bandnum,'(i3)') n shortname = 'opac_'//trim(adjustl(bandnum)) diff --git a/src/tracer/MOM_tracer_flow_control.F90 b/src/tracer/MOM_tracer_flow_control.F90 index 5a176cd3f9..716745093c 100644 --- a/src/tracer/MOM_tracer_flow_control.F90 +++ b/src/tracer/MOM_tracer_flow_control.F90 @@ -489,11 +489,15 @@ subroutine call_tracer_column_fns(h_old, h_new, ea, eb, fluxes, Hml, dt, G, GV, evap_CFL_limit=evap_CFL_limit, & minimum_forcing_depth=minimum_forcing_depth) #ifdef _USE_GENERIC_TRACER - if (CS%use_MOM_generic_tracer) & + if (CS%use_MOM_generic_tracer) then + if (US%QRZ_T_to_W_m2 /= 1.0) call MOM_error(FATAL, "MOM_generic_tracer_column_physics "//& + "has not been written to permit dimensionsal rescaling. Set all 4 of the "//& + "[QRZT]_RESCALE_POWER parameters to 0.") call MOM_generic_tracer_column_physics(h_old, h_new, ea, eb, fluxes, Hml, US%T_to_s*dt, & G, GV, CS%MOM_generic_tracer_CSp, tv, optics, & evap_CFL_limit=evap_CFL_limit, & minimum_forcing_depth=minimum_forcing_depth) + endif #endif if (CS%use_pseudo_salt_tracer) & call pseudo_salt_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, & @@ -541,9 +545,13 @@ subroutine call_tracer_column_fns(h_old, h_new, ea, eb, fluxes, Hml, dt, G, GV, call OCMIP2_CFC_column_physics(h_old, h_new, ea, eb, fluxes, dt, & G, GV, US, CS%OCMIP2_CFC_CSp) #ifdef _USE_GENERIC_TRACER - if (CS%use_MOM_generic_tracer) & + if (CS%use_MOM_generic_tracer) then + if (US%QRZ_T_to_W_m2 /= 1.0) call MOM_error(FATAL, "MOM_generic_tracer_column_physics "//& + "has not been written to permit dimensionsal rescaling. Set all 4 of the "//& + "[QRZT]_RESCALE_POWER parameters to 0.") call MOM_generic_tracer_column_physics(h_old, h_new, ea, eb, fluxes, Hml, US%T_to_s*dt, & G, GV, CS%MOM_generic_tracer_CSp, tv, optics) + endif #endif if (CS%use_pseudo_salt_tracer) & call pseudo_salt_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, & From 1ee0592940c282461e5820bbc73345ce44f9ea10 Mon Sep 17 00:00:00 2001 From: Matthew Harrison Date: Thu, 20 Feb 2020 12:15:39 -0500 Subject: [PATCH 071/316] Removed midas_vertmap module and relocated associated subroutines related to non-ALE initilization into MOM_tracer_Z_init. --- .../MOM_state_initialization.F90 | 22 +- src/initialization/midas_vertmap.F90 | 827 ------------------ src/tracer/MOM_tracer_Z_init.F90 | 380 +++++++- 3 files changed, 388 insertions(+), 841 deletions(-) delete mode 100644 src/initialization/midas_vertmap.F90 diff --git a/src/initialization/MOM_state_initialization.F90 b/src/initialization/MOM_state_initialization.F90 index ed6aa5a44d..7f420439f3 100644 --- a/src/initialization/MOM_state_initialization.F90 +++ b/src/initialization/MOM_state_initialization.F90 @@ -88,10 +88,7 @@ module MOM_state_initialization use dense_water_initialization, only : dense_water_initialize_TS use dense_water_initialization, only : dense_water_initialize_sponges use dumbbell_initialization, only : dumbbell_initialize_sponges - -use midas_vertmap, only : find_interfaces, tracer_Z_init -use midas_vertmap, only : determine_temperature - +use MOM_tracer_Z_init, only : find_interfaces, tracer_Z_init_array, determine_temperature use MOM_ALE, only : ALE_initRegridding, ALE_CS, ALE_initThicknessToCoord use MOM_ALE, only : ALE_remap_scalar, ALE_build_grid, ALE_regrid_accelerated use MOM_regridding, only : regridding_CS, set_regrid_params, getCoordinateResolution @@ -99,7 +96,6 @@ module MOM_state_initialization 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 - use fms_io_mod, only : field_size implicit none ; private @@ -2018,7 +2014,7 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, G, GV, US, PF, just_read_param real, dimension(:,:,:), allocatable, target :: temp_z, salt_z, mask_z real, dimension(:,:,:), allocatable :: rho_z ! Densities in Z-space [R ~> kg m-3] real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1) :: zi ! Interface heights [Z ~> m]. - real, dimension(SZI_(G),SZJ_(G)) :: nlevs + integer, dimension(SZI_(G),SZJ_(G)) :: nlevs real, dimension(SZI_(G)) :: press ! Pressures [Pa]. ! Local variables for ALE remapping @@ -2323,7 +2319,7 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, G, GV, US, PF, just_read_param ! Next find interface positions using local arrays ! nlevs contains the number of valid data points in each column - nlevs = sum(mask_z,dim=3) + nlevs = int(sum(mask_z,dim=3)) ! Rb contains the layer interface densities allocate(Rb(nz+1)) @@ -2359,12 +2355,12 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, G, GV, US, PF, just_read_param endif endif - tv%T(is:ie,js:je,:) = tracer_z_init(temp_z(is:ie,js:je,:), z_edges_in, zi(is:ie,js:je,:), & - nkml, nkbl, missing_value, G%mask2dT(is:ie,js:je), nz, & - nlevs(is:ie,js:je),dbg,idbg,jdbg, eps_z=eps_z) - tv%S(is:ie,js:je,:) = tracer_z_init(salt_z(is:ie,js:je,:), z_edges_in, zi(is:ie,js:je,:), & - nkml, nkbl, missing_value, G%mask2dT(is:ie,js:je), nz, & - nlevs(is:ie,js:je), eps_z=eps_z) + call tracer_z_init_array(temp_z(is:ie,js:je,:), z_edges_in, zi(is:ie,js:je,:), & + nkml, nkbl, missing_value, G%mask2dT(is:ie,js:je), nz, & + nlevs(is:ie,js:je), eps_z, tv%T(is:ie,js:je,:)) + call tracer_z_init_array(salt_z(is:ie,js:je,:), z_edges_in, zi(is:ie,js:je,:), & + nkml, nkbl, missing_value, G%mask2dT(is:ie,js:je), nz, & + nlevs(is:ie,js:je), eps_z, tv%S(is:ie,js:je,:)) do k=1,nz nPoints = 0 ; tempAvg = 0. ; saltAvg = 0. diff --git a/src/initialization/midas_vertmap.F90 b/src/initialization/midas_vertmap.F90 deleted file mode 100644 index e6c586ed23..0000000000 --- a/src/initialization/midas_vertmap.F90 +++ /dev/null @@ -1,827 +0,0 @@ -!> Routines for initialization callable from MOM6 or Python (MIDAS) -module MIDAS_vertmap - -! This file is part of MOM6. See LICENSE.md for the license. - -! If calling from MOM6, use MOM6 interfaces for EOS functions -#ifndef PY_SOLO -use MOM_EOS, only : EOS_type, calculate_density,calculate_density_derivs - -implicit none ; private - -public tracer_z_init, determine_temperature, fill_boundaries -public find_interfaces, meshgrid -#endif - -! A note on unit descriptions in comments: MOM6 uses units that can be rescaled for dimensional -! consistency testing. These are noted in comments with units like Z, H, L, and T, along with -! their mks counterparts with notation like "a velocity [Z T-1 ~> m s-1]". If the units -! vary with the Boussinesq approximation, the Boussinesq variant is given first. - -!> Fill grid edges -interface fill_boundaries - module procedure fill_boundaries_real - module procedure fill_boundaries_int -end interface - -contains - -#ifdef PY_SOLO -!> Calculate seawater equation of state, given T[degC], S[PSU], and p[Pa] -!! Returns density [kg m-3] -!! -!! These EOS routines are needed only for the stand-alone version of the code -!! The subroutines in this file implement the equation of state for -!! sea water using the formulae given by Wright, 1997, J. Atmos. -!! Ocean. Tech., 14, 735-740. -function wright_eos_2d(T,S,p) result(rho) - real(kind=8), dimension(:,:), intent(in) :: T,S !< temperature [degC] and Salinity [psu] - real, intent(in) :: p !< pressure [Pa] - real(kind=8), dimension(size(T,1),size(T,2)) :: rho !< potential density [kg m-3] - ! Local variables - real(kind=8) :: a0,a1,a2,b0,b1,b2,b3,b4,b5,c0,c1,c2,c3,c4,c5 - 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 - - do k=1,size(T,2) - do i=1,size(T,1) - al0 = a0 + a1*T(i,k) +a2*S(i,k) - p0 = b0 + b4*S(i,k) + T(i,k) * (b1 + T(i,k)*(b2 + & - b3*T(i,k)) + b5*S(i,k)) - lam = c0 +c4*S(i,k) + T(i,k) * (c1 + T(i,k)*(c2 + & - c3*T(i,k)) + c5*S(i,k)) - I_denom = 1.0 / (lam + al0*(p+p0)) - rho(i,k) = (p + p0) * I_denom - enddo - enddo - - return -end function wright_eos_2d - -!> Calculate seawater thermal expansion coefficient given T[degC],S[PSU],p[Pa] -!! Returns density [kg m-3 degC-1] -!! -!! The subroutines in this file implement the equation of state for -!! sea water using the formulae given by Wright, 1997, J. Atmos. -!! Ocean. Tech., 14, 735-740. -function alpha_wright_eos_2d(T,S,p) result(drho_dT) - real(kind=8), dimension(:,:), intent(in) :: T,S !< temperature [degC] and Salinity [psu] - real, intent(in) :: p !< pressure [Pa] - real(kind=8), dimension(size(T,1),size(T,2)) :: drho_dT !< partial derivative of density with - !! respect to temperature [kg m-3 degC-1] - ! Local variables - real(kind=8) :: a0,a1,a2,b0,b1,b2,b3,b4,b5,c0,c1,c2,c3,c4,c5 - 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 - - do k=1,size(T,2) - do i=1,size(T,1) - al0 = a0 + a1*T(i,k) +a2*S(i,k) - p0 = b0 + b4*S(i,k) + T(i,k) * (b1 + T(i,k)*(b2 + & - b3*T(i,k)) + b5*S(i,k)) - lam = c0 +c4*S(i,k) + T(i,k) * (c1 + T(i,k)*(c2 + & - c3*T(i,k)) + c5*S(i,k)) - I_denom = 1.0 / (lam + al0*(p+p0)) - I_denom2 = I_denom*I_denom - drho_dT(i,k) = I_denom2*(lam*(b1+T(i,k)*(2*b2 + & - 3*b3*T(i,k)) + b5*S(i,k)) - (p+p0)*((p+p0)*a1 + & - (c1+T(i,k)*(2*c2 + 3*c3*T(i,k)) + c5*S(i,k)))) - enddo - enddo - - return -end function alpha_wright_eos_2d - -!> Calculate seawater haline expansion coefficient given T[degC],S[PSU],p[Pa] -!! Returns density [kg m-3 PSU-1] -!! -!! The subroutines in this file implement the equation of state for -!! sea water using the formulae given by Wright, 1997, J. Atmos. -!! Ocean. Tech., 14, 735-740. -function beta_wright_eos_2d(T,S,p) result(drho_dS) - real(kind=8), dimension(:,:), intent(in) :: T,S !< temperature [degC] and salinity [psu] - real, intent(in) :: p !< pressure [Pa] - real(kind=8), dimension(size(T,1),size(T,2)) :: drho_dS !< partial derivative of density with - !! respect to salinity [kg m-3 PSU-1] - ! Local variables - real(kind=8) :: a0,a1,a2,b0,b1,b2,b3,b4,b5,c0,c1,c2,c3,c4,c5 - 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 - - do k=1,size(T,2) - do i=1,size(T,1) - al0 = a0 + a1*T(i,k) +a2*S(i,k) - p0 = b0 + b4*S(i,k) + T(i,k) * (b1 + T(i,k)*(b2 + & - b3*T(i,k)) + b5*S(i,k)) - lam = c0 +c4*S(i,k) + T(i,k) * (c1 + T(i,k)*(c2 + & - c3*T(i,k)) + c5*S(i,k)) - I_denom = 1.0 / (lam + al0*(p+p0)) - I_denom2 = I_denom*I_denom - drho_dS(i,k) = I_denom2*(lam*(b4+b5*T(i,k)) - & - (p+p0)*((p+p0)*a2 + (c4+c5*T(i,k)))) - enddo - enddo - - return -end function beta_wright_eos_2d -#endif - -!> Layer model routine for remapping tracers -function tracer_z_init(tr_in, z_edges, e, nkml, nkbl, land_fill, wet, nlay, nlevs, & - debug, i_debug, j_debug, eps_z) result(tr) - real, dimension(:,:,:), intent(in) :: tr_in !< The z-space array of tracer concentrations that is read in. - real, dimension(size(tr_in,3)+1), intent(in) :: z_edges !< The depths of the cell edges in the input z* data - !! [Z ~> m or m] - integer, intent(in) :: nlay !< The number of vertical layers in the target grid - real, dimension(size(tr_in,1),size(tr_in,2),nlay+1), & - intent(in) :: e !< The depths of the target layer interfaces [Z ~> m or m] - integer, intent(in) :: nkml !< The number of mixed layers - integer, intent(in) :: nkbl !< The number of buffer layers - real, intent(in) :: land_fill !< fill in data over land (1) - real, dimension(size(tr_in,1),size(tr_in,2)), & - intent(in) :: wet !< The wet mask for the source data (valid points) - real, dimension(size(tr_in,1),size(tr_in,2)), & - optional, intent(in) :: nlevs !< The number of input levels with valid data - logical, optional, intent(in) :: debug !< optional debug flag - integer, optional, intent(in) :: i_debug !< i-index of point for debugging - integer, optional, intent(in) :: j_debug !< j-index of point for debugging - real, optional, intent(in) :: eps_z !< A negligibly small layer thickness [Z ~> m or m]. - real, dimension(size(tr_in,1),size(tr_in,2),nlay) :: tr !< tracers in layer space - - ! Local variables - real, dimension(size(tr_in,3)) :: tr_1d !< a copy of the input tracer concentrations in a column. - real, dimension(nlay+1) :: e_1d ! A 1-d column of intreface heights, in the same units as e. - real, dimension(nlay) :: tr_ ! A 1-d column of tracer concentrations - integer, dimension(size(tr_in,1),size(tr_in,2)) :: nlevs_data !< number of valid levels in the input dataset - integer :: n,i,j,k,l,nx,ny,nz,nt,kz - integer :: k_top,k_bot,k_bot_prev,kk,kstart - real :: sl_tr ! The tracer concentration slope times the layer thickness, in tracer units. - real :: epsln_Z ! A negligibly thin layer thickness [Z ~> m]. - real, dimension(size(tr_in,3)) :: wt !< The fractional weight for each layer in the range between z1 and z2 - real, dimension(size(tr_in,3)) :: z1, z2 ! z1 and z2 are the fractional depths of the top and bottom - ! limits of the part of a z-cell that contributes to a layer, relative - ! to the cell center and normalized by the cell thickness [nondim]. - ! Note that -1/2 <= z1 <= z2 <= 1/2. - - logical :: debug_msg, debug_, debug_pt - - nx = size(tr_in,1); ny=size(tr_in,2); nz = size(tr_in,3) - - nlevs_data = size(tr_in,3) - if (PRESENT(nlevs)) nlevs_data = anint(nlevs) - epsln_Z = 1.0e-10 ; if (PRESENT(eps_z)) epsln_Z = eps_z - - debug_=.false. ; if (PRESENT(debug)) debug_ = debug - debug_msg = debug_ - debug_pt = debug_ ; if (PRESENT(i_debug) .and. PRESENT(j_debug)) debug_pt = debug_ - - do j=1,ny - i_loop: do i=1,nx - if (nlevs_data(i,j) == 0 .or. wet(i,j) == 0.) then - tr(i,j,:) = land_fill - cycle i_loop - endif - - do k=1,nz - tr_1d(k) = tr_in(i,j,k) - enddo - - do k=1,nlay+1 - e_1d(k) = e(i,j,k) - enddo - k_bot = 1 ; k_bot_prev = -1 - do k=1,nlay - if (e_1d(k+1) > z_edges(1)) then - tr(i,j,k) = tr_1d(1) - elseif (e_1d(k) < z_edges(nlevs_data(i,j)+1)) then - if (debug_msg) then - print *,'*** WARNING : Found interface below valid range of z data ' - print *,'(i,j,z_bottom,interface)= ',& - i,j,z_edges(nlevs_data(i,j)+1),e_1d(k) - print *,'z_edges= ',z_edges - print *,'e=',e_1d - print *,'*** I will extrapolate below using the bottom-most valid values' - debug_msg = .false. - endif - tr(i,j,k) = tr_1d(nlevs_data(i,j)) - - else - kstart=k_bot - call find_overlap(z_edges, e_1d(k), e_1d(k+1), nlevs_data(i,j), & - kstart, k_top, k_bot, wt, z1, z2) - - if (debug_pt) 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 - kz = k_top - sl_tr=0.0; ! cur_tr=0.0 - if (kz /= k_bot_prev) then - ! Calculate the intra-cell profile. - if ((kz < nlevs_data(i,j)) .and. (kz > 1)) then - sl_tr = find_limited_slope(tr_1d, z_edges, kz) - endif - endif - if (kz > nlevs_data(i,j)) kz = nlevs_data(i,j) - ! This is the piecewise linear form. - tr(i,j,k) = wt(kz) * (tr_1d(kz) + 0.5*sl_tr*(z2(kz) + z1(kz))) - ! For the piecewise parabolic form add the following... - ! + C1_3*wt(kz) * cur_tr*(z2(kz)**2 + z2(kz)*z1(kz) + z1(kz)**2)) - if (debug_pt) 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 - - do kz=k_top+1,k_bot-1 - tr(i,j,k) = tr(i,j,k) + wt(kz)*tr_1d(kz) - enddo - - if (debug_pt) then ; if ((i == i_debug) .and. (j == j_debug)) then - print *,'0003 k,tr = ',k,tr(i,j,k) - endif ; endif - - if (k_bot > k_top) then - kz = k_bot - ! Calculate the intra-cell profile. - sl_tr = 0.0 ! ; cur_tr = 0.0 - if ((kz < nlevs_data(i,j)) .and. (kz > 1)) then - sl_tr = find_limited_slope(tr_1d, z_edges, kz) - endif - ! This is the piecewise linear form. - tr(i,j,k) = tr(i,j,k) + wt(kz) * & - (tr_1d(kz) + 0.5*sl_tr*(z2(kz) + z1(kz))) - ! For the piecewise parabolic form add the following... - ! + C1_3*cur_tr*(z2(kz)**2 + z2(kz)*z1(kz) + z1(kz)**2)) - - if (debug_pt) 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 ; endif - - endif - k_bot_prev = k_bot - - endif - enddo ! k-loop - - do k=2,nlay ! simply fill vanished layers with adjacent value - if (e_1d(k)-e_1d(k+1) <= epsln_Z) tr(i,j,k)=tr(i,j,k-1) - enddo - - enddo i_loop - enddo - -end function tracer_z_init - -!> Return the index where to insert item x in list a, assuming a is sorted. -!! The return values [i] is such that all e in a[:i-1] have e <= x, and all e in -!! a[i:] have e > x. So if x already appears in the list, will -!! insert just after the rightmost x already there. -!! Optional args lo (default 1) and hi (default len(a)) bound the -!! slice of a to be searched. -function bisect_fast(a, x, lo, hi) result(bi_r) - real, dimension(:,:), intent(in) :: a !< Sorted list - real, dimension(:), intent(in) :: x !< Item to be inserted - integer, dimension(size(a,1)), optional, intent(in) :: lo !< Lower bracket of optional range to search - integer, dimension(size(a,1)), optional, intent(in) :: hi !< Upper bracket of optional range to search - integer, dimension(size(a,1),size(x,1)) :: bi_r - - integer :: mid,num_x,num_a,i - integer, dimension(size(a,1)) :: lo_,hi_,lo0,hi0 - integer :: nprofs,j - - lo_=1;hi_=size(a,2);num_x=size(x,1);bi_r=-1;nprofs=size(a,1) - - if (PRESENT(lo)) then - where (lo>0) lo_=lo - endif - if (PRESENT(hi)) then - where (hi>0) hi_=hi - endif - - lo0=lo_;hi0=hi_ - - do j=1,nprofs - do i=1,num_x - lo_=lo0;hi_=hi0 - do while (lo_(j) < hi_(j)) - mid = (lo_(j)+hi_(j))/2 - if (x(i) < a(j,mid)) then - hi_(j) = mid - else - lo_(j) = mid+1 - endif - enddo - bi_r(j,i)=lo_(j) - enddo - enddo - - - return - -end function bisect_fast - -#ifdef PY_SOLO -! Only for stand-alone python - -!> This subroutine determines the potential temperature and salinity that -!! is consistent with the target density using provided initial guess -subroutine determine_temperature(temp, salt, R, p_ref, niter, land_fill, h, k_start) - real(kind=8), dimension(:,:,:), intent(inout) :: temp !< potential temperature [degC] - real(kind=8), dimension(:,:,:), intent(inout) :: salt !< salinity [PSU] - real(kind=8), dimension(size(temp,3)), intent(in) :: R !< desired potential density [kg m-3]. - real, intent(in) :: p_ref !< reference pressure [Pa]. - integer, intent(in) :: niter !< maximum number of iterations - integer, intent(in) :: k_start !< starting index (i.e. below the buffer layer) - real, intent(in) :: land_fill !< land fill value - real(kind=8), dimension(:,:,:), intent(in) :: h !< layer thickness . Do not iterate for massless layers - - ! Local variables - real, parameter :: T_max = 35.0, T_min = -2.0 -#else -!> This subroutine determines the potential temperature and salinity that -!! is consistent with the target density using provided initial guess -subroutine determine_temperature(temp, salt, R, p_ref, niter, land_fill, h, k_start, eos) - real, dimension(:,:,:), intent(inout) :: temp !< potential temperature [degC] - real, dimension(:,:,:), intent(inout) :: salt !< salinity [PSU] - real, dimension(size(temp,3)), intent(in) :: R !< desired potential density [kg m-3]. - real, intent(in) :: p_ref !< reference pressure [Pa]. - integer, intent(in) :: niter !< maximum number of iterations - integer, intent(in) :: k_start !< starting index (i.e. below the buffer layer) - real, intent(in) :: land_fill !< land fill value - real, dimension(:,:,:), intent(in) :: h !< layer thickness, used only to avoid working on massless layers - type(eos_type), pointer :: eos !< seawater equation of state control structure - - real, parameter :: T_max = 31.0, T_min = -2.0 -#endif - ! Local variables (All of which need documentation!) - 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 - real(kind=8), dimension(size(temp,1)) :: press - integer :: nx, ny, nz, nt, i, j, k, n, itt - real :: dT_dS_gauge ! The relative penalizing of temperature to salinity changes when - ! minimizing property changes while correcting density [degC ppt-1]. - real :: I_denom ! The inverse of the magnitude squared of the density gradient in - ! T-S space streched with dT_dS_gauge [m6 kg-2 ppt-1] - logical :: adjust_salt, old_fit - real, parameter :: S_min = 0.5, S_max=65.0 - real, parameter :: tol_T=1.e-4, tol_S=1.e-4, tol_rho=1.e-4 - real, parameter :: max_t_adj=1.0, max_s_adj = 0.5 - - old_fit = .true. ! reproduces siena behavior - - ! ### The whole determine_temperature subroutine needs to be reexamined, both the algorithms - ! and the extensive use of hard-coded dimensional parameters. - - ! We will switch to the newer method which simultaneously adjusts - ! temp and salt based on the ratio of the thermal and haline coefficients, once it is tested. - - nx=size(temp,1) ; ny=size(temp,2) ; nz=size(temp,3) - - press(:) = p_ref - - do j=1,ny - dS(:,:) = 0. ! Needs to be zero everywhere since there is a maxval(abs(dS)) later... - T=temp(:,j,:) - S=salt(:,j,:) - hin=h(:,j,:) - dT=0.0 - adjust_salt = .true. - iter_loop: do itt = 1,niter -#ifdef PY_SOLO - rho=wright_eos_2d(T,S,p_ref) - drho_dT=alpha_wright_eos_2d(T,S,p_ref) -#else - do k=1, nz - call calculate_density(T(:,k), S(:,k), press, rho(:,k), 1, nx, eos) - call calculate_density_derivs(T(:,k), S(:,k), press, drho_dT(:,k), drho_dS(:,k), 1, nx, eos) - enddo -#endif - do k=k_start,nz ; do i=1,nx - -! if (abs(rho(i,k)-R(k))>tol .and. hin(i,k)>epsln .and. abs(T(i,k)-land_fill) < epsln) then - if (abs(rho(i,k)-R(k))>tol_rho) then - if (old_fit) then - dT(i,k) = max(min((R(k)-rho(i,k)) / drho_dT(i,k), max_t_adj), -max_t_adj) - T(i,k) = max(min(T(i,k)+dT(i,k), T_max), T_min) - else - dT_dS_gauge = 10.0 ! 10 degC is weighted equivalently to 1 ppt. - I_denom = 1.0 / (drho_dS(i,k)**2 + dT_dS_gauge**2*drho_dT(i,k)**2) - dS(i,k) = (R(k)-rho(i,k)) * drho_dS(i,k) * I_denom - dT(i,k) = (R(k)-rho(i,k)) * dT_dS_gauge**2*drho_dT(i,k) * I_denom - - T(i,k) = max(min(T(i,k)+dT(i,k), T_max), T_min) - S(i,k) = max(min(S(i,k)+dS(i,k), S_max), S_min) - endif - endif - enddo ; enddo - if (maxval(abs(dT)) < tol_T) then - adjust_salt = .false. - exit iter_loop - endif - enddo iter_loop - - if (adjust_salt .and. old_fit) then ; do itt = 1,niter -#ifdef PY_SOLO - rho = wright_eos_2d(T,S,p_ref) - drho_dS = beta_wright_eos_2d(T,S,p_ref) -#else - do k=1, nz - call calculate_density(T(:,k),S(:,k),press,rho(:,k),1,nx,eos) - call calculate_density_derivs(T(:,k),S(:,k),press,drho_dT(:,k),drho_dS(:,k),1,nx,eos) - enddo -#endif - do k=k_start,nz ; do i=1,nx -! if (abs(rho(i,k)-R(k))>tol .and. hin(i,k)>epsln .and. abs(T(i,k)-land_fill) < epsln ) then - if (abs(rho(i,k)-R(k)) > tol_rho) then - dS(i,k) = max(min((R(k)-rho(i,k)) / drho_dS(i,k), max_s_adj), -max_s_adj) - S(i,k) = max(min(S(i,k)+dS(i,k), S_max), S_min) - endif - enddo ; enddo - if (maxval(abs(dS)) < tol_S) exit - enddo ; endif - - temp(:,j,:)=T(:,:) - salt(:,j,:)=S(:,:) - enddo - -end subroutine determine_temperature - -!> This subroutine determines the layers bounded by interfaces e that overlap -!! with the depth range between Z_top and Z_bot, and also the fractional weights -!! of each layer. It also calculates the normalized relative depths of the range -!! of each layer that overlaps that depth range. -!! Note that by convention, e decreases with increasing k and Z_top > Z_bot. -subroutine find_overlap(e, Z_top, Z_bot, k_max, k_start, k_top, k_bot, wt, z1, z2) - real, dimension(:), intent(in) :: e !< The interface positions, [Z ~> m] or other units. - real, intent(in) :: Z_top !< The top of the range being mapped to, [Z ~> m] or other units. - real, intent(in) :: Z_bot !< The bottom of the range being mapped to, [Z ~> m] or other units. - integer, intent(in) :: k_max !< The number of valid layers. - integer, intent(in) :: k_start !< The layer at which to start searching. - integer, intent(out) :: k_top !< The index of the top layer that overlap with the depth range. - integer, intent(out) :: k_bot !< The index of the bottom layer that overlap with the depth range. - real, dimension(:), intent(out) :: wt !< The relative weights of each layer from k_top to k_bot [nondim]. - real, dimension(:), intent(out) :: z1 !< Depth of the top limit of layer that contributes to a level [nondim]. - real, dimension(:), intent(out) :: z2 !< Depth of the bottom limit of layer that contributes to a level [nondim]. - - ! Local variables - real :: Ih, e_c, tot_wt, I_totwt - integer :: k - - wt(:) = 0.0 ; z1(:) = 0.0 ; z2(:) = 0.0 ; k_bot = k_max - wt(1) = 1.0 ; z1(1) = -0.5 ; z2(1) = 0.5 - - do k=k_start,k_max ; if (e(K+1) < Z_top) exit ; enddo - k_top = k - if (k_top > k_max) return - - ! Determine the fractional weights of each layer. - ! Note that by convention, e and Z_int decrease with increasing k. - if (e(K+1) <= Z_bot) then - wt(k) = 1.0 ; k_bot = k - Ih = 0.0 ; if (e(K) /= e(K+1)) Ih = 1.0 / (e(K)-e(K+1)) - e_c = 0.5*(e(K)+e(K+1)) - z1(k) = (e_c - MIN(e(K), Z_top)) * Ih - z2(k) = (e_c - Z_bot) * Ih - else - wt(k) = MIN(e(K),Z_top) - e(K+1) ; tot_wt = wt(k) ! These are always > 0. - if (e(K) /= e(K+1)) then - z1(k) = (0.5*(e(K)+e(K+1)) - MIN(e(K), Z_top)) / (e(K)-e(K+1)) - else ; z1(k) = -0.5 ; endif - z2(k) = 0.5 - k_bot = k_max - do k=k_top+1,k_max - if (e(K+1) <= Z_bot) then - k_bot = k - wt(k) = e(K) - Z_bot ; z1(k) = -0.5 - if (e(K) /= e(K+1)) then - z2(k) = (0.5*(e(K)+e(K+1)) - Z_bot) / (e(K)-e(K+1)) - else ; z2(k) = 0.5 ; endif - else - wt(k) = e(K) - e(K+1) ; z1(k) = -0.5 ; z2(k) = 0.5 - endif - tot_wt = tot_wt + wt(k) ! wt(k) is always > 0. - if (k>=k_bot) exit - enddo - - I_totwt = 0.0 ; if (tot_wt > 0.0) I_totwt = 1.0 / tot_wt - do k=k_top,k_bot ; wt(k) = I_totwt*wt(k) ; enddo - endif - -end subroutine find_overlap - -!> This function determines a limited slope for val to be advected with -!! a piecewise limited scheme. -function find_limited_slope(val, e, k) result(slope) - real, dimension(:), intent(in) :: val !< A column of values that are being interpolated, in arbitrary units [A]. - real, dimension(:), intent(in) :: e !< A column's interface heights [Z ~> m] or other units. - integer, intent(in) :: k !< The layer whose slope is being determined. - real :: slope !< The normalized slope in the intracell distribution of val [A Z-1 ~> A m-1] or other units. - ! Local variables - real :: d1, d2 ! Thicknesses in the units of e [Z ~> m]. - - d1 = 0.5*(e(K-1)-e(K+1)) ; d2 = 0.5*(e(K)-e(K+2)) - if (((val(k)-val(k-1)) * (val(k)-val(k+1)) >= 0.0) .or. (d1*d2 <= 0.0)) then - slope = 0.0 - else - slope = ((d1**2)*(val(k+1) - val(k)) + (d2**2)*(val(k) - val(k-1))) * & - (e(K) - e(K+1)) / (d1*d2*(d1+d2)) - ! slope = 0.5*(val(k+1) - val(k-1)) - ! This is S.J. Lin's form of the PLM limiter. - slope = sign(1.0, slope) * min(abs(slope), & - 2.0*(max(val(k-1), val(k), val(k+1)) - val(k)), & - 2.0*(val(k) - min(val(k-1), val(k), val(k+1)))) - endif - -end function find_limited_slope - -!> Find interface positions corresponding to density profile -function find_interfaces(rho, zin, Rb, depth, nlevs, nkml, nkbl, hml, debug, eps_z, eps_rho) result(zi) - real, dimension(:,:,:), & - intent(in) :: rho !< potential density in z-space [kg m-3 or R ~> kg m-3] - real, dimension(size(rho,3)), & - intent(in) :: zin !< Input data levels [m or Z ~> m]. - real, dimension(:), intent(in) :: Rb !< target interface densities [kg m-3 or R ~> kg m-3] - real, dimension(size(rho,1),size(rho,2)), & - intent(in) :: depth !< ocean depth [Z ~> m]. - real, dimension(size(rho,1),size(rho,2)), & - optional, intent(in) :: nlevs !< number of valid points in each column - logical, optional, intent(in) :: debug !< optional debug flag - integer, optional, intent(in) :: nkml !< number of mixed layer pieces - integer, optional, intent(in) :: nkbl !< number of buffer layer pieces - real, optional, intent(in) :: hml !< mixed layer depth [Z ~> m]. - real, optional, intent(in) :: eps_z !< A negligibly small layer thickness [m or Z ~> m]. - real, optional, intent(in) :: eps_rho !< A negligibly small density difference [kg m-3 or R ~> kg m-3]. - real, dimension(size(rho,1),size(rho,2),size(Rb,1)) :: zi !< The returned interface, in the same units az zin. - - ! Local variables - real, dimension(size(rho,1),size(rho,3)) :: rho_ ! A slice of densities [R ~> kg m-3] - real, dimension(size(rho,1)) :: depth_ - logical :: unstable - integer :: dir - integer, dimension(size(rho,1),size(Rb,1)) :: ki_ - real, dimension(size(rho,1),size(Rb,1)) :: zi_ - integer, dimension(size(rho,1),size(rho,2)) :: nlevs_data - integer, dimension(size(rho,1)) :: lo, hi - real :: slope,rsm,drhodz,hml_ - integer :: n,i,j,k,l,nx,ny,nz,nt - integer :: nlay,kk,nkml_,nkbl_ - logical :: debug_ = .false. - real :: epsln_Z ! A negligibly thin layer thickness [m or Z ~> m]. - real :: epsln_rho ! A negligibly small density change [kg m-3 or R ~> kg m-3]. - real, parameter :: zoff=0.999 - - nlay=size(Rb)-1 - - zi(:,:,:) = 0.0 - - if (PRESENT(debug)) debug_=debug - - nx = size(rho,1); ny=size(rho,2); nz = size(rho,3) - nlevs_data(:,:) = size(rho,3) - - nkml_ = 0 ; if (PRESENT(nkml)) nkml_ = max(0, nkml) - nkbl_ = 0 ; if (PRESENT(nkbl)) nkbl_ = max(0, nkbl) - hml_ = 0.0 ; if (PRESENT(hml)) hml_ = hml - epsln_Z = 1.0e-10 ; if (PRESENT(eps_z)) epsln_Z = eps_z - epsln_rho = 1.0e-10 ; if (PRESENT(eps_rho)) epsln_rho = eps_rho - - if (PRESENT(nlevs)) then - nlevs_data(:,:) = nlevs(:,:) - endif - - do j=1,ny - rho_(:,:) = rho(:,j,:) - i_loop: do i=1,nx - if (debug_) then - print *,'looking for interfaces, i,j,nlevs= ',i,j,nlevs_data(i,j) - print *,'initial density profile= ', rho_(i,:) - endif - unstable=.true. - dir=1 - do while (unstable) - unstable=.false. - 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 == 2) then - rho_(i,k-1) = rho_(i,k)-epsln_rho - else - drhodz = (rho_(i,k+1)-rho_(i,k-1)) / (zin(k+1)-zin(k-1)) - if (drhodz < 0.0) unstable=.true. - rho_(i,k) = rho_(i,k-1) + drhodz*zoff*(zin(k)-zin(k-1)) - endif - endif - enddo - dir = -1*dir - else - do k=nlevs_data(i,j)-1,2,-1 - if (rho_(i,k+1) - rho_(i,k) < 0.0) then - if (k == nlevs_data(i,j)-1) then - rho_(i,k+1) = rho_(i,k-1)+epsln_rho - else - drhodz = (rho_(i,k+1)-rho_(i,k-1))/(zin(k+1)-zin(k-1)) - if (drhodz < 0.0) unstable=.true. - rho_(i,k) = rho_(i,k+1)-drhodz*(zin(k+1)-zin(k)) - endif - endif - enddo - dir = -1*dir - endif - enddo - if (debug_) then - print *,'final density profile= ', rho_(i,:) - endif - enddo i_loop - - ki_(:,:) = 0 - zi_(:,:) = 0.0 - depth_(:) = -1.0*depth(:,j) - lo(:) = 1 - hi(:) = nlevs_data(:,j) - ki_ = bisect_fast(rho_, Rb, lo, hi) - ki_(:,:) = max(1, ki_(:,:)-1) - do i=1,nx - do l=2,nlay - slope = (zin(ki_(i,l)+1) - zin(ki_(i,l))) / max(rho_(i,ki_(i,l)+1) - rho_(i,ki_(i,l)),epsln_rho) - zi_(i,l) = -1.0*(zin(ki_(i,l)) + slope*(Rb(l)-rho_(i,ki_(i,l)))) - zi_(i,l) = max(zi_(i,l), depth_(i)) - zi_(i,l) = min(zi_(i,l), -1.0*hml_) - enddo - zi_(i,nlay+1) = depth_(i) - do l=2,nkml_+1 - zi_(i,l) = max(hml_*((1.0-real(l))/real(nkml_)), depth_(i)) - enddo - do l=nlay,nkml_+2,-1 - if (zi_(i,l) < zi_(i,l+1) + epsln_Z) zi_(i,l) = zi_(i,l+1) + epsln_Z - if (zi_(i,l) > -1.0*hml_) zi_(i,l) = max(-1.0*hml_, depth_(i)) - enddo - enddo - zi(:,j,:) = zi_(:,:) - enddo - -end function find_interfaces - -!> Create a 2d-mesh of grid coordinates from 1-d arrays -subroutine meshgrid(x,y,x_T,y_T) - real, dimension(:), intent(in) :: x !< input x coordinates - real, dimension(:), intent(in) :: y !< input y coordinates - real, dimension(size(x,1),size(y,1)), intent(inout) :: x_T !< output 2-d version - real, dimension(size(x,1),size(y,1)), intent(inout) :: y_T !< output 2-d version - - integer :: ni,nj,i,j - - ni=size(x,1);nj=size(y,1) - - do j=1,nj - x_T(:,j)=x(:) - enddo - - do i=1,ni - y_T(i,:)=y(:) - enddo - - return - -end subroutine meshgrid - -!> Solve del2 (zi) = 0 using successive iterations -!! with a 5 point stencil. Only points fill==1 are -!! modified. Except where bad==1, information propagates -!! isotropically in index space. The resulting solution -!! in each region is an approximation to del2(zi)=0 subject to -!! boundary conditions along the valid points curve bounding this region. -subroutine smooth_heights(zi,fill,bad,sor,niter,cyclic_x, tripolar_n) - real, dimension(:,:), intent(inout) :: zi !< interface positions [m] or arbitrary - integer, dimension(size(zi,1),size(zi,2)), intent(in) :: fill !< points to be smoothed - integer, dimension(size(zi,1),size(zi,2)), intent(in) :: bad !< ignore these points - real, intent(in) :: sor !< successive over-relaxation coefficient (typically 0.6) - integer, intent(in) :: niter !< maximum number of iterations - logical, intent(in) :: cyclic_x !< input grid cyclic condition in the zonal direction - logical, intent(in) :: tripolar_n !< tripolar Arctic fold flag - - integer :: i,j,k,n - integer :: ni,nj - - real, dimension(size(zi,1),size(zi,2)) :: res, m - integer, dimension(size(zi,1),size(zi,2),4) :: B - real, dimension(0:size(zi,1)+1,0:size(zi,2)+1) :: mp - integer, dimension(0:size(zi,1)+1,0:size(zi,2)+1) :: nm - - real :: Isum, bsum - - ni=size(zi,1); nj=size(zi,2) - - - mp=fill_boundaries(zi,cyclic_x,tripolar_n) - - B(:,:,:)=0.0 - nm=fill_boundaries(bad,cyclic_x,tripolar_n) - - do j=1,nj - do i=1,ni - 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 - enddo - enddo - - do n=1,niter - do j=1,nj - do i=1,ni - 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)+& - B(i,j,3)*mp(i,j+1)+B(i,j,4)*mp(i,j-1)) - mp(i,j) - endif - enddo - enddo - res(:,:)=res(:,:)*sor - - do j=1,nj - do i=1,ni - mp(i,j)=mp(i,j)+res(i,j) - enddo - enddo - - zi(:,:)=mp(1:ni,1:nj) - mp = fill_boundaries(zi,cyclic_x,tripolar_n) - enddo - - return - -end subroutine smooth_heights - -!> Fill grid edges -function fill_boundaries_int(m,cyclic_x,tripolar_n) result(mp) - integer, dimension(:,:), intent(in) :: m !< input array - logical, intent(in) :: cyclic_x !< zonal cyclic condition - logical, intent(in) :: tripolar_n !< northern fold condition - integer, dimension(0:size(m,1)+1,0:size(m,2)+1) :: mp !< output filled array - ! Local variables - real, dimension(size(m,1),size(m,2)) :: m_real - real, dimension(0:size(m,1)+1,0:size(m,2)+1) :: mp_real - - m_real = real(m) - - mp_real = fill_boundaries_real(m_real,cyclic_x,tripolar_n) - - mp = int(mp_real) - - return - -end function fill_boundaries_int - -!> fill grid edges -function fill_boundaries_real(m,cyclic_x,tripolar_n) result(mp) - real, dimension(:,:), intent(in) :: m !< input array - logical, intent(in) :: cyclic_x !< zonal cyclic condition - logical, intent(in) :: tripolar_n !< northern fold condition - real, dimension(0:size(m,1)+1,0:size(m,2)+1) :: mp !< output filled array - - integer :: ni,nj,i,j - - ni=size(m,1); nj=size(m,2) - - mp(1:ni,1:nj)=m(:,:) - - if (cyclic_x) then - mp(0,1:nj)=m(ni,1:nj) - mp(ni+1,1:nj)=m(1,1:nj) - else - mp(0,1:nj)=m(1,1:nj) - mp(ni+1,1:nj)=m(ni,1:nj) - endif - - mp(1:ni,0)=m(1:ni,1) - if (tripolar_n) then - do i=1,ni - mp(i,nj+1)=m(ni-i+1,nj) - enddo - else - mp(1:ni,nj+1)=m(1:ni,nj) - endif - - return - -end function fill_boundaries_real - -end module MIDAS_vertmap diff --git a/src/tracer/MOM_tracer_Z_init.F90 b/src/tracer/MOM_tracer_Z_init.F90 index b7e00b4eba..875af6b549 100644 --- a/src/tracer/MOM_tracer_Z_init.F90 +++ b/src/tracer/MOM_tracer_Z_init.F90 @@ -7,6 +7,7 @@ module MOM_tracer_Z_init ! use MOM_file_parser, only : get_param, log_version, param_file_type use MOM_grid, only : ocean_grid_type use MOM_io, only : MOM_read_data +use MOM_EOS, only : EOS_type, calculate_density, calculate_density_derivs use MOM_unit_scaling, only : unit_scale_type use netcdf @@ -15,7 +16,7 @@ module MOM_tracer_Z_init #include -public tracer_Z_init +public tracer_Z_init, tracer_Z_init_array, find_interfaces, determine_temperature ! A note on unit descriptions in comments: MOM6 uses units that can be rescaled for dimensional ! consistency testing. These are noted in comments with units like Z, H, L, and T, along with @@ -274,6 +275,112 @@ function tracer_Z_init(tr, h, filename, tr_name, G, US, missing_val, land_val) end function tracer_Z_init +!> Layer model routine for remapping tracers +!! from pseudo-z coordinates into layers defined +!! by target interface positions. +subroutine tracer_z_init_array(tr_in, z_edges, e, nkml, nkbl, land_fill, wet, nlay, nlevs, & + eps_z, tr) + real, dimension(:,:,:), intent(in) :: tr_in !< The z-space array of tracer concentrations that is read in. + real, dimension(size(tr_in,3)+1), intent(in) :: z_edges !< The depths of the cell edges in the input z* data + !! [Z ~> m or m] + integer, intent(in) :: nlay !< The number of vertical layers in the target grid + real, dimension(size(tr_in,1),size(tr_in,2),nlay+1), & + intent(in) :: e !< The depths of the target layer interfaces [Z ~> m or m] + integer, intent(in) :: nkml !< The number of mixed layers + integer, intent(in) :: nkbl !< The number of buffer layers + real, intent(in) :: land_fill !< fill in data over land (1) + real, dimension(size(tr_in,1),size(tr_in,2)), & + intent(in) :: wet !< The wet mask for the source data (valid points) + integer, dimension(size(tr_in,1),size(tr_in,2)), & + intent(in) :: nlevs !< The number of input levels with valid data + real, intent(in) :: eps_z ! A negligibly thin layer thickness [Z ~> m]. + real, dimension(size(tr_in,1),size(tr_in,2),nlay), intent(out) :: tr !< tracers in layer space + + ! Local variables + real, dimension(size(tr_in,3)) :: tr_1d !< a copy of the input tracer concentrations in a column. + real, dimension(nlay+1) :: e_1d ! A 1-d column of intreface heights, in the same units as e. + real, dimension(nlay) :: tr_ ! A 1-d column of tracer concentrations + integer :: n,i,j,k,l,nx,ny,nz,nt,kz + integer :: k_top,k_bot,k_bot_prev,kk,kstart + real :: sl_tr ! The tracer concentration slope times the layer thickness, in tracer units. + real, dimension(size(tr_in,3)) :: wt !< The fractional weight for each layer in the range between z1 and z2 + real, dimension(size(tr_in,3)) :: z1, z2 ! z1 and z2 are the fractional depths of the top and bottom + ! limits of the part of a z-cell that contributes to a layer, relative + ! to the cell center and normalized by the cell thickness [nondim]. + ! Note that -1/2 <= z1 <= z2 <= 1/2. + + nx = size(tr_in,1); ny=size(tr_in,2); nz = size(tr_in,3) + + + do j=1,ny + i_loop: do i=1,nx + if (nlevs(i,j) == 0 .or. wet(i,j) == 0.) then + tr(i,j,:) = land_fill + cycle i_loop + endif + + do k=1,nz + tr_1d(k) = tr_in(i,j,k) + enddo + + do k=1,nlay+1 + e_1d(k) = e(i,j,k) + enddo + k_bot = 1 ; k_bot_prev = -1 + do k=1,nlay + if (e_1d(k+1) > z_edges(1)) then + tr(i,j,k) = tr_1d(1) + elseif (e_1d(k) < z_edges(nlevs(i,j)+1)) then + tr(i,j,k) = tr_1d(nlevs(i,j)) + + else + kstart=k_bot + call find_overlap(z_edges, e_1d(k), e_1d(k+1), nlevs(i,j), & + kstart, k_top, k_bot, wt, z1, z2) + kz = k_top + sl_tr=0.0; ! cur_tr=0.0 + if (kz /= k_bot_prev) then + ! Calculate the intra-cell profile. + if ((kz < nlevs(i,j)) .and. (kz > 1)) then + sl_tr = find_limited_slope(tr_1d, z_edges, kz) + endif + endif + if (kz > nlevs(i,j)) kz = nlevs(i,j) + ! This is the piecewise linear form. + tr(i,j,k) = wt(kz) * (tr_1d(kz) + 0.5*sl_tr*(z2(kz) + z1(kz))) + ! For the piecewise parabolic form add the following... + ! + C1_3*wt(kz) * cur_tr*(z2(kz)**2 + z2(kz)*z1(kz) + z1(kz)**2)) + do kz=k_top+1,k_bot-1 + tr(i,j,k) = tr(i,j,k) + wt(kz)*tr_1d(kz) + enddo + + if (k_bot > k_top) then + kz = k_bot + ! Calculate the intra-cell profile. + sl_tr = 0.0 ! ; cur_tr = 0.0 + if ((kz < nlevs(i,j)) .and. (kz > 1)) then + sl_tr = find_limited_slope(tr_1d, z_edges, kz) + endif + ! This is the piecewise linear form. + tr(i,j,k) = tr(i,j,k) + wt(kz) * & + (tr_1d(kz) + 0.5*sl_tr*(z2(kz) + z1(kz))) + ! For the piecewise parabolic form add the following... + ! + C1_3*cur_tr*(z2(kz)**2 + z2(kz)*z1(kz) + z1(kz)**2)) + endif + k_bot_prev = k_bot + + endif + enddo ! k-loop + + do k=2,nlay ! simply fill vanished layers with adjacent value + if (e_1d(k)-e_1d(k+1) <= eps_z) tr(i,j,k)=tr(i,j,k-1) + enddo + + enddo i_loop + enddo + +end subroutine tracer_z_init_array + !> This subroutine reads the vertical coordinate data for a field from a NetCDF file. !! It also might read the missing value attribute for that same field. subroutine read_Z_edges(filename, tr_name, z_edges, nz_out, has_edges, & @@ -498,5 +605,276 @@ function find_limited_slope(val, e, k) result(slope) end function find_limited_slope +!> Find interface positions corresponding to density profile +function find_interfaces(rho, zin, Rb, depth, nlevs, nkml, nkbl, hml, debug, eps_z, eps_rho) result(zi) + real, dimension(:,:,:), & + intent(in) :: rho !< potential density in z-space [kg m-3 or R ~> kg m-3] + real, dimension(size(rho,3)), & + intent(in) :: zin !< Input data levels [m or Z ~> m]. + real, dimension(:), intent(in) :: Rb !< target interface densities [kg m-3 or R ~> kg m-3] + real, dimension(size(rho,1),size(rho,2)), & + intent(in) :: depth !< ocean depth [Z ~> m]. + integer, dimension(size(rho,1),size(rho,2)), & + optional, intent(in) :: nlevs !< number of valid points in each column + logical, optional, intent(in) :: debug !< optional debug flag + integer, optional, intent(in) :: nkml !< number of mixed layer pieces + integer, optional, intent(in) :: nkbl !< number of buffer layer pieces + real, optional, intent(in) :: hml !< mixed layer depth [Z ~> m]. + real, optional, intent(in) :: eps_z !< A negligibly small layer thickness [m or Z ~> m]. + real, optional, intent(in) :: eps_rho !< A negligibly small density difference [kg m-3 or R ~> kg m-3]. + real, dimension(size(rho,1),size(rho,2),size(Rb,1)) :: zi !< The returned interface, in the same units az zin. + + ! Local variables + real, dimension(size(rho,1),size(rho,3)) :: rho_ ! A slice of densities [R ~> kg m-3] + real, dimension(size(rho,1)) :: depth_ + logical :: unstable + integer :: dir + integer, dimension(size(rho,1),size(Rb,1)) :: ki_ + real, dimension(size(rho,1),size(Rb,1)) :: zi_ + integer, dimension(size(rho,1),size(rho,2)) :: nlevs_data + integer, dimension(size(rho,1)) :: lo, hi + real :: slope,rsm,drhodz,hml_ + integer :: n,i,j,k,l,nx,ny,nz,nt + integer :: nlay,kk,nkml_,nkbl_ + logical :: debug_ = .false. + real :: epsln_Z ! A negligibly thin layer thickness [m or Z ~> m]. + real :: epsln_rho ! A negligibly small density change [kg m-3 or R ~> kg m-3]. + real, parameter :: zoff=0.999 + + nlay=size(Rb)-1 + + zi(:,:,:) = 0.0 + + if (PRESENT(debug)) debug_=debug + + nx = size(rho,1); ny=size(rho,2); nz = size(rho,3) + nlevs_data(:,:) = size(rho,3) + + nkml_ = 0 ; if (PRESENT(nkml)) nkml_ = max(0, nkml) + nkbl_ = 0 ; if (PRESENT(nkbl)) nkbl_ = max(0, nkbl) + hml_ = 0.0 ; if (PRESENT(hml)) hml_ = hml + epsln_Z = 1.0e-10 ; if (PRESENT(eps_z)) epsln_Z = eps_z + epsln_rho = 1.0e-10 ; if (PRESENT(eps_rho)) epsln_rho = eps_rho + + if (PRESENT(nlevs)) then + nlevs_data(:,:) = nlevs(:,:) + endif + + do j=1,ny + rho_(:,:) = rho(:,j,:) + i_loop: do i=1,nx + if (debug_) then + print *,'looking for interfaces, i,j,nlevs= ',i,j,nlevs_data(i,j) + print *,'initial density profile= ', rho_(i,:) + endif + unstable=.true. + dir=1 + do while (unstable) + unstable=.false. + 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 == 2) then + rho_(i,k-1) = rho_(i,k)-epsln_rho + else + drhodz = (rho_(i,k+1)-rho_(i,k-1)) / (zin(k+1)-zin(k-1)) + if (drhodz < 0.0) unstable=.true. + rho_(i,k) = rho_(i,k-1) + drhodz*zoff*(zin(k)-zin(k-1)) + endif + endif + enddo + dir = -1*dir + else + do k=nlevs_data(i,j)-1,2,-1 + if (rho_(i,k+1) - rho_(i,k) < 0.0) then + if (k == nlevs_data(i,j)-1) then + rho_(i,k+1) = rho_(i,k-1)+epsln_rho + else + drhodz = (rho_(i,k+1)-rho_(i,k-1))/(zin(k+1)-zin(k-1)) + if (drhodz < 0.0) unstable=.true. + rho_(i,k) = rho_(i,k+1)-drhodz*(zin(k+1)-zin(k)) + endif + endif + enddo + dir = -1*dir + endif + enddo + if (debug_) then + print *,'final density profile= ', rho_(i,:) + endif + enddo i_loop + + ki_(:,:) = 0 + zi_(:,:) = 0.0 + depth_(:) = -1.0*depth(:,j) + lo(:) = 1 + hi(:) = nlevs_data(:,j) + ki_ = bisect_fast(rho_, Rb, lo, hi) + ki_(:,:) = max(1, ki_(:,:)-1) + do i=1,nx + do l=2,nlay + slope = (zin(ki_(i,l)+1) - zin(ki_(i,l))) / max(rho_(i,ki_(i,l)+1) - rho_(i,ki_(i,l)),epsln_rho) + zi_(i,l) = -1.0*(zin(ki_(i,l)) + slope*(Rb(l)-rho_(i,ki_(i,l)))) + zi_(i,l) = max(zi_(i,l), depth_(i)) + zi_(i,l) = min(zi_(i,l), -1.0*hml_) + enddo + zi_(i,nlay+1) = depth_(i) + do l=2,nkml_+1 + zi_(i,l) = max(hml_*((1.0-real(l))/real(nkml_)), depth_(i)) + enddo + do l=nlay,nkml_+2,-1 + if (zi_(i,l) < zi_(i,l+1) + epsln_Z) zi_(i,l) = zi_(i,l+1) + epsln_Z + if (zi_(i,l) > -1.0*hml_) zi_(i,l) = max(-1.0*hml_, depth_(i)) + enddo + enddo + zi(:,j,:) = zi_(:,:) + enddo + +end function find_interfaces + +!> This subroutine determines the potential temperature and salinity that +!! is consistent with the target density using provided initial guess +subroutine determine_temperature(temp, salt, R, p_ref, niter, land_fill, h, k_start, eos) + real, dimension(:,:,:), intent(inout) :: temp !< potential temperature [degC] + real, dimension(:,:,:), intent(inout) :: salt !< salinity [PSU] + real, dimension(size(temp,3)), intent(in) :: R !< desired potential density [kg m-3]. + real, intent(in) :: p_ref !< reference pressure [Pa]. + integer, intent(in) :: niter !< maximum number of iterations + integer, intent(in) :: k_start !< starting index (i.e. below the buffer layer) + real, intent(in) :: land_fill !< land fill value + real, dimension(:,:,:), intent(in) :: h !< layer thickness, used only to avoid working on massless layers + type(eos_type), pointer :: eos !< seawater equation of state control structure + + real, parameter :: T_max = 31.0, T_min = -2.0 + ! Local variables (All of which need documentation!) + 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 + real(kind=8), dimension(size(temp,1)) :: press + integer :: nx, ny, nz, nt, i, j, k, n, itt + real :: dT_dS_gauge ! The relative penalizing of temperature to salinity changes when + ! minimizing property changes while correcting density [degC ppt-1]. + real :: I_denom ! The inverse of the magnitude squared of the density gradient in + ! T-S space streched with dT_dS_gauge [m6 kg-2 ppt-1] + logical :: adjust_salt, old_fit + real, parameter :: S_min = 0.5, S_max=65.0 + real, parameter :: tol_T=1.e-4, tol_S=1.e-4, tol_rho=1.e-4 + real, parameter :: max_t_adj=1.0, max_s_adj = 0.5 + + old_fit = .true. ! reproduces siena behavior + + ! ### The whole determine_temperature subroutine needs to be reexamined, both the algorithms + ! and the extensive use of hard-coded dimensional parameters. + + ! We will switch to the newer method which simultaneously adjusts + ! temp and salt based on the ratio of the thermal and haline coefficients, once it is tested. + + nx=size(temp,1) ; ny=size(temp,2) ; nz=size(temp,3) + + press(:) = p_ref + + do j=1,ny + dS(:,:) = 0. ! Needs to be zero everywhere since there is a maxval(abs(dS)) later... + T=temp(:,j,:) + S=salt(:,j,:) + hin=h(:,j,:) + dT=0.0 + adjust_salt = .true. + iter_loop: do itt = 1,niter + do k=1, nz + call calculate_density(T(:,k), S(:,k), press, rho(:,k), 1, nx, eos) + call calculate_density_derivs(T(:,k), S(:,k), press, drho_dT(:,k), drho_dS(:,k), 1, nx, eos) + enddo + do k=k_start,nz ; do i=1,nx + +! if (abs(rho(i,k)-R(k))>tol .and. hin(i,k)>epsln .and. abs(T(i,k)-land_fill) < epsln) then + if (abs(rho(i,k)-R(k))>tol_rho) then + if (old_fit) then + dT(i,k) = max(min((R(k)-rho(i,k)) / drho_dT(i,k), max_t_adj), -max_t_adj) + T(i,k) = max(min(T(i,k)+dT(i,k), T_max), T_min) + else + dT_dS_gauge = 10.0 ! 10 degC is weighted equivalently to 1 ppt. + I_denom = 1.0 / (drho_dS(i,k)**2 + dT_dS_gauge**2*drho_dT(i,k)**2) + dS(i,k) = (R(k)-rho(i,k)) * drho_dS(i,k) * I_denom + dT(i,k) = (R(k)-rho(i,k)) * dT_dS_gauge**2*drho_dT(i,k) * I_denom + + T(i,k) = max(min(T(i,k)+dT(i,k), T_max), T_min) + S(i,k) = max(min(S(i,k)+dS(i,k), S_max), S_min) + endif + endif + enddo ; enddo + if (maxval(abs(dT)) < tol_T) then + adjust_salt = .false. + exit iter_loop + endif + enddo iter_loop + + if (adjust_salt .and. old_fit) then ; do itt = 1,niter + do k=1, nz + call calculate_density(T(:,k),S(:,k),press,rho(:,k),1,nx,eos) + call calculate_density_derivs(T(:,k),S(:,k),press,drho_dT(:,k),drho_dS(:,k),1,nx,eos) + enddo + do k=k_start,nz ; do i=1,nx +! if (abs(rho(i,k)-R(k))>tol .and. hin(i,k)>epsln .and. abs(T(i,k)-land_fill) < epsln ) then + if (abs(rho(i,k)-R(k)) > tol_rho) then + dS(i,k) = max(min((R(k)-rho(i,k)) / drho_dS(i,k), max_s_adj), -max_s_adj) + S(i,k) = max(min(S(i,k)+dS(i,k), S_max), S_min) + endif + enddo ; enddo + if (maxval(abs(dS)) < tol_S) exit + enddo ; endif + + temp(:,j,:)=T(:,:) + salt(:,j,:)=S(:,:) + enddo + +end subroutine determine_temperature + +!> Return the index where to insert item x in list a, assuming a is sorted. +!! The return values [i] is such that all e in a[:i-1] have e <= x, and all e in +!! a[i:] have e > x. So if x already appears in the list, will +!! insert just after the rightmost x already there. +!! Optional args lo (default 1) and hi (default len(a)) bound the +!! slice of a to be searched. +function bisect_fast(a, x, lo, hi) result(bi_r) + real, dimension(:,:), intent(in) :: a !< Sorted list + real, dimension(:), intent(in) :: x !< Item to be inserted + integer, dimension(size(a,1)), optional, intent(in) :: lo !< Lower bracket of optional range to search + integer, dimension(size(a,1)), optional, intent(in) :: hi !< Upper bracket of optional range to search + integer, dimension(size(a,1),size(x,1)) :: bi_r + + integer :: mid,num_x,num_a,i + integer, dimension(size(a,1)) :: lo_,hi_,lo0,hi0 + integer :: nprofs,j + + lo_=1;hi_=size(a,2);num_x=size(x,1);bi_r=-1;nprofs=size(a,1) + + if (PRESENT(lo)) then + where (lo>0) lo_=lo + endif + if (PRESENT(hi)) then + where (hi>0) hi_=hi + endif + + lo0=lo_;hi0=hi_ + + do j=1,nprofs + do i=1,num_x + lo_=lo0;hi_=hi0 + do while (lo_(j) < hi_(j)) + mid = (lo_(j)+hi_(j))/2 + if (x(i) < a(j,mid)) then + hi_(j) = mid + else + lo_(j) = mid+1 + endif + enddo + bi_r(j,i)=lo_(j) + enddo + enddo + + + return + +end function bisect_fast end module MOM_tracer_Z_init From d37f0d55dbe99cb5eb285fc89a8b0b9d8529f457 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 21 Feb 2020 13:10:11 -0500 Subject: [PATCH 072/316] +Rescaled units of 7 fluxes%heat_content arrays Rescaled the units of 7 fluxes%heat_content arrays (like heat_content_lrunoff) to [Q R Z T-1] for dimensional consistency testing. Also calculate and pass some combined heat flux diagnostics in rescaled units. All answers are bitwise identical. --- .../MOM_surface_forcing_gfdl.F90 | 4 +- .../ice_solo_driver/MOM_surface_forcing.F90 | 21 +- .../mct_driver/mom_surface_forcing_mct.F90 | 4 +- .../mom_surface_forcing_nuopc.F90 | 4 +- src/core/MOM_forcing_type.F90 | 195 +++++++++--------- src/diagnostics/MOM_sum_output.F90 | 2 +- .../vertical/MOM_bulk_mixed_layer.F90 | 6 +- .../vertical/MOM_diabatic_aux.F90 | 8 +- 8 files changed, 119 insertions(+), 125 deletions(-) diff --git a/config_src/coupled_driver/MOM_surface_forcing_gfdl.F90 b/config_src/coupled_driver/MOM_surface_forcing_gfdl.F90 index 800a938064..e850ad50ed 100644 --- a/config_src/coupled_driver/MOM_surface_forcing_gfdl.F90 +++ b/config_src/coupled_driver/MOM_surface_forcing_gfdl.F90 @@ -470,13 +470,13 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, endif if (associated(IOB%runoff_hflx)) then - fluxes%heat_content_lrunoff(i,j) = kg_m2_s_conversion * IOB%runoff_hflx(i-i0,j-j0) * G%mask2dT(i,j) + fluxes%heat_content_lrunoff(i,j) = US%W_m2_to_QRZ_T * IOB%runoff_hflx(i-i0,j-j0) * G%mask2dT(i,j) if (CS%check_no_land_fluxes) & call check_mask_val_consistency(IOB%runoff_hflx(i-i0,j-j0), G%mask2dT(i,j), i, j, 'runoff_hflx', G) endif if (associated(IOB%calving_hflx)) then - fluxes%heat_content_frunoff(i,j) = kg_m2_s_conversion * IOB%calving_hflx(i-i0,j-j0) * G%mask2dT(i,j) + fluxes%heat_content_frunoff(i,j) = US%W_m2_to_QRZ_T * IOB%calving_hflx(i-i0,j-j0) * G%mask2dT(i,j) if (CS%check_no_land_fluxes) & call check_mask_val_consistency(IOB%calving_hflx(i-i0,j-j0), G%mask2dT(i,j), i, j, 'calving_hflx', G) endif diff --git a/config_src/ice_solo_driver/MOM_surface_forcing.F90 b/config_src/ice_solo_driver/MOM_surface_forcing.F90 index d736574f2a..38001f9812 100644 --- a/config_src/ice_solo_driver/MOM_surface_forcing.F90 +++ b/config_src/ice_solo_driver/MOM_surface_forcing.F90 @@ -602,7 +602,7 @@ subroutine buoyancy_forcing_from_files(sfc_state, fluxes, day, dt, G, US, CS) type(surface_forcing_CS), pointer :: CS !< A pointer to the control structure returned by a !! previous surface_forcing_init call - real :: rhoXcp ! mean density times the heat capacity [J m-3 degC-1]. + real :: rhoXcp ! mean density times the heat capacity [Q R degC-1 ~> J m-3 degC-1]. real :: Irho0 ! inverse Boussinesq reference density [m3 kg-1]. integer :: i, j, is, ie, js, je, isd, ied, jsd, jed @@ -629,7 +629,7 @@ subroutine buoyancy_forcing_from_files(sfc_state, fluxes, day, dt, G, US, CS) ! allocate and initialize arrays call buoyancy_forcing_allocate(fluxes, G, CS) - if (CS%use_temperature) rhoXcp = CS%Rho0 * US%Q_to_J_kg*fluxes%C_p + if (CS%use_temperature) rhoXcp = CS%Rho0 * fluxes%C_p Irho0 = 1.0/(US%R_to_kg_m3*CS%Rho0) ! Read the file containing the buoyancy forcing. @@ -729,8 +729,7 @@ subroutine buoyancy_forcing_from_files(sfc_state, fluxes, day, dt, G, US, CS) fluxes%sw(i,j) = fluxes%sw(i,j) * G%mask2dT(i,j) fluxes%latent(i,j) = fluxes%latent(i,j) * G%mask2dT(i,j) - fluxes%heat_content_lrunoff(i,j) = US%Q_to_J_kg*fluxes%C_p * & - fluxes%lrunoff(i,j)*sfc_state%SST(i,j) + fluxes%heat_content_lrunoff(i,j) = fluxes%C_p * fluxes%lrunoff(i,j)*sfc_state%SST(i,j) fluxes%latent_evap_diag(i,j) = fluxes%latent_evap_diag(i,j) * G%mask2dT(i,j) fluxes%latent_fprec_diag(i,j) = -fluxes%fprec(i,j)*US%J_kg_to_Q*hlf fluxes%latent_frunoff_diag(i,j) = -fluxes%frunoff(i,j)*US%J_kg_to_Q*hlf @@ -742,13 +741,13 @@ subroutine buoyancy_forcing_from_files(sfc_state, fluxes, day, dt, G, US, CS) if (CS%use_temperature) then do j=js,je ; do i=is,ie if (G%mask2dT(i,j) > 0) then - fluxes%heat_restore(i,j) = G%mask2dT(i,j) * & - ((CS%T_Restore(i,j) - sfc_state%SST(i,j)) * rhoXcp * US%Z_to_m*US%s_to_T*CS%Flux_const) + fluxes%heat_added(i,j) = G%mask2dT(i,j) * & + ((CS%T_Restore(i,j) - sfc_state%SST(i,j)) * rhoXcp * CS%Flux_const) fluxes%vprec(i,j) = - (CS%Rho0*CS%Flux_const) * & (CS%S_Restore(i,j) - sfc_state%SSS(i,j)) / & (0.5*(sfc_state%SSS(i,j) + CS%S_Restore(i,j))) else - fluxes%heat_restore(i,j) = 0.0 + fluxes%heat_added(i,j) = 0.0 fluxes%vprec(i,j) = 0.0 endif enddo ; enddo @@ -876,13 +875,13 @@ subroutine buoyancy_forcing_linear(sfc_state, fluxes, day, dt, G, US, CS) T_restore = CS%T_south + (CS%T_north-CS%T_south)*y S_restore = CS%S_south + (CS%S_north-CS%S_south)*y if (G%mask2dT(i,j) > 0) then - fluxes%heat_restore(i,j) = G%mask2dT(i,j) * US%QRZ_T_to_W_m2 * & + fluxes%heat_added(i,j) = G%mask2dT(i,j) * & ((T_Restore - sfc_state%SST(i,j)) * ((CS%Rho0 * fluxes%C_p) * CS%Flux_const)) fluxes%vprec(i,j) = - (CS%Rho0*CS%Flux_const) * & (S_Restore - sfc_state%SSS(i,j)) / & (0.5*(sfc_state%SSS(i,j) + S_Restore)) else - fluxes%heat_restore(i,j) = 0.0 + fluxes%heat_added(i,j) = 0.0 fluxes%vprec(i,j) = 0.0 endif enddo ; enddo @@ -1090,9 +1089,7 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, tracer_flow_C "The constant that relates the restoring surface fluxes "//& "to the relative surface anomalies (akin to a piston "//& "velocity). Note the non-MKS units.", & - units="m day-1", scale=US%m_to_Z*US%T_to_s, fail_if_missing=.true.) - ! Convert CS%Flux_const from m day-1 to m s-1. - CS%Flux_const = CS%Flux_const / 86400.0 + units="m day-1", scale=US%m_to_Z*US%T_to_s/86400.0, fail_if_missing=.true.) if (trim(CS%buoy_config) == "linear") then call get_param(param_file, mdl, "SST_NORTH", CS%T_north, & "With buoy_config linear, the sea surface temperature "//& diff --git a/config_src/mct_driver/mom_surface_forcing_mct.F90 b/config_src/mct_driver/mom_surface_forcing_mct.F90 index 61c43bf44c..16f6506572 100644 --- a/config_src/mct_driver/mom_surface_forcing_mct.F90 +++ b/config_src/mct_driver/mom_surface_forcing_mct.F90 @@ -457,14 +457,14 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, 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. + ! heat_content_frunoff. I am setting 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) if (associated(IOB%calving_hflx)) & - fluxes%heat_content_frunoff(i,j) = kg_m2_s_conversion * IOB%calving_hflx(i-i0,j-j0) * G%mask2dT(i,j) + fluxes%heat_content_frunoff(i,j) = US%W_m2_to_QRZ_T * IOB%calving_hflx(i-i0,j-j0) * G%mask2dT(i,j) ! longwave radiation, sum up and down (W/m2) if (associated(IOB%lw_flux)) & diff --git a/config_src/nuopc_driver/mom_surface_forcing_nuopc.F90 b/config_src/nuopc_driver/mom_surface_forcing_nuopc.F90 index 03158b932e..9c6ca72567 100644 --- a/config_src/nuopc_driver/mom_surface_forcing_nuopc.F90 +++ b/config_src/nuopc_driver/mom_surface_forcing_nuopc.F90 @@ -459,10 +459,10 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, fluxes%mass_berg(i,j) = IOB%mass_berg(i-i0,j-j0) * G%mask2dT(i,j) if (associated(IOB%runoff_hflx)) & - fluxes%heat_content_lrunoff(i,j) = IOB%runoff_hflx(i-i0,j-j0) * G%mask2dT(i,j) + fluxes%heat_content_lrunoff(i,j) = US%W_m2_to_QRZ_T * IOB%runoff_hflx(i-i0,j-j0) * G%mask2dT(i,j) if (associated(IOB%calving_hflx)) & - fluxes%heat_content_frunoff(i,j) = kg_m2_s_conversion*IOB%calving_hflx(i-i0,j-j0) * G%mask2dT(i,j) + fluxes%heat_content_frunoff(i,j) = US%W_m2_to_QRZ_T * IOB%calving_hflx(i-i0,j-j0) * G%mask2dT(i,j) if (associated(IOB%lw_flux)) & fluxes%lw(i,j) = US%W_m2_to_QRZ_T * IOB%lw_flux(i-i0,j-j0) * G%mask2dT(i,j) diff --git a/src/core/MOM_forcing_type.F90 b/src/core/MOM_forcing_type.F90 index 1a9b1692c2..46f7530972 100644 --- a/src/core/MOM_forcing_type.F90 +++ b/src/core/MOM_forcing_type.F90 @@ -96,16 +96,16 @@ module MOM_forcing_type ! heat associated with water crossing ocean surface real, pointer, dimension(:,:) :: & - heat_content_cond => NULL(), & !< heat content associated with condensating water [J kg-1 R Z T-1 ~> W m-2] - heat_content_lprec => NULL(), & !< heat content associated with liquid >0 precip [J kg-1 R Z T-1 ~> W m-2] + heat_content_cond => NULL(), & !< heat content associated with condensating water [Q R Z T-1 ~> W m-2] + heat_content_lprec => NULL(), & !< heat content associated with liquid >0 precip [Q R Z T-1 ~> W m-2] heat_content_icemelt => NULL(), & !< heat content associated with snow and seaice - !! melt and formation [J kg-1 R Z T-1 ~> W m-2] - heat_content_fprec => NULL(), & !< heat content associated with frozen precip [J kg-1 R Z T-1 ~> W m-2] - heat_content_vprec => NULL(), & !< heat content associated with virtual >0 precip [J kg-1 R Z T-1 ~> W m-2] - heat_content_lrunoff => NULL(), & !< heat content associated with liquid runoff [J kg-1 R Z T-1 ~> W m-2] - heat_content_frunoff => NULL(), & !< heat content associated with frozen runoff [J kg-1 R Z T-1 ~> W m-2] - heat_content_massout => NULL(), & !< heat content associated with mass leaving ocean [J kg-1 R Z T-1 ~> W m-2] - heat_content_massin => NULL() !< heat content associated with mass entering ocean [J kg-1 R Z T-1 ~> W m-2] + !! melt and formation [Q R Z T-1 ~> W m-2] + heat_content_fprec => NULL(), & !< heat content associated with frozen precip [Q R Z T-1 ~> W m-2] + heat_content_vprec => NULL(), & !< heat content associated with virtual >0 precip [Q R Z T-1 ~> W m-2] + heat_content_lrunoff => NULL(), & !< heat content associated with liquid runoff [Q R Z T-1 ~> W m-2] + heat_content_frunoff => NULL(), & !< heat content associated with frozen runoff [Q R Z T-1 ~> W m-2] + heat_content_massout => NULL(), & !< heat content associated with mass leaving ocean [Q R Z T-1 ~> W m-2] + heat_content_massin => NULL() !< heat content associated with mass entering ocean [Q R Z T-1 ~> W m-2] ! salt mass flux (contributes to ocean mass only if non-Bouss ) real, pointer, dimension(:,:) :: & @@ -414,13 +414,12 @@ subroutine extractFluxes1d(G, GV, US, fluxes, optics, nsw, j, dt_in_T, & real :: Ih_limit ! inverse depth at which surface fluxes start to be limited ! or 0 for no limiting [H-1 ~> m-1 or m2 kg-1] real :: scale ! scale scales away fluxes if depth < FluxRescaleDepth - real :: W_m2_to_H_T ! converts W/m^2 to H degC T-1 [degC H T-1 W-2 m2 ~> degC m3 J-1 or degC kg J-1] real :: QRZ_to_H ! Converts heat in Q R Z to H degC [degC H Q-1 R-1 Z-1 ~> degC m3 J-1 or degC kg J-1] real :: RZ_T_to_W_m2_degC ! Converts mass fluxes to heat fluxes per degree temperature ! change [W m-2 degC-1 T R-1 Z-1 ~> J kg degC] - real :: I_Cp ! 1.0 / C_p [kg decC J-1] + real :: I_Cp ! 1.0 / C_p [degC Q-1 ~> kg degC J-1] real :: RZcp_to_H ! Unit convsersion factors divided by the heat capacity - ! [kg degC H R-1 Z-1 J-1 ~> degC m3 J-1 or kg degC J-1] + ! [degC H R-1 Z-1 Q-1 ~> degC m3 J-1 or kg degC J-1] logical :: calculate_diags ! Indicate to calculate/update diagnostic arrays character(len=200) :: mesg integer :: is, ie, nz, i, k, n @@ -444,11 +443,9 @@ subroutine extractFluxes1d(G, GV, US, fluxes, optics, nsw, j, dt_in_T, & Ih_limit = 0.0 ; if (FluxRescaleDepth > 0.0) Ih_limit = 1.0 / FluxRescaleDepth ! RZ_T_to_W_m2_degC = US%Q_to_J_kg*fluxes%C_p*US%R_to_kg_m3*US%Z_to_m*US%s_to_T RZ_T_to_W_m2_degC = US%QRZ_T_to_W_m2*fluxes%C_p - I_Cp = 1.0 / (US%Q_to_J_kg*fluxes%C_p) - W_m2_to_H_T = 1.0 / (US%s_to_T * GV%H_to_kg_m2 * US%Q_to_J_kg * fluxes%C_p) - QRZ_to_H = US%R_to_kg_m3 * US%Z_to_m * (1.0 / (GV%H_to_kg_m2 *fluxes%C_p)) - - RZcP_to_H = 1.0 / (GV%H_to_RZ * US%Q_to_J_kg*fluxes%C_p) + I_Cp = 1.0 / fluxes%C_p + QRZ_to_H = US%R_to_kg_m3 * US%Z_to_m * (1.0 / (GV%H_to_kg_m2 * fluxes%C_p)) + RZcP_to_H = 1.0 / (GV%H_to_RZ * fluxes%C_p) is = G%isc ; ie = G%iec ; nz = G%ke @@ -500,7 +497,7 @@ subroutine extractFluxes1d(G, GV, US, fluxes, optics, nsw, j, dt_in_T, & Pen_sw_tot(i) = 0.0 if (nsw >= 1) then do n=1,nsw - Pen_SW_bnd(n,i) = US%QRZ_T_to_W_m2*W_m2_to_H_T*scale*dt_in_T * max(0.0, Pen_SW_bnd(n,i)) + Pen_SW_bnd(n,i) = RZcP_to_H*scale*dt_in_T * max(0.0, Pen_SW_bnd(n,i)) Pen_sw_tot(i) = Pen_sw_tot(i) + Pen_SW_bnd(n,i) enddo else @@ -511,7 +508,7 @@ subroutine extractFluxes1d(G, GV, US, fluxes, optics, nsw, j, dt_in_T, & pen_sw_tot_rate(i) = 0.0 if (nsw >= 1) then do n=1,nsw - Pen_SW_bnd_rate(n,i) = US%QRZ_T_to_W_m2*W_m2_to_H_T*scale * max(0.0, Pen_SW_bnd_rate(n,i)) + Pen_SW_bnd_rate(n,i) = RZcP_to_H*scale * max(0.0, Pen_SW_bnd_rate(n,i)) pen_sw_tot_rate(i) = pen_sw_tot_rate(i) + pen_sw_bnd_rate(n,i) enddo else @@ -584,18 +581,18 @@ subroutine extractFluxes1d(G, GV, US, fluxes, optics, nsw, j, dt_in_T, & ! CIME provides heat flux from snow&ice melt (seaice_melt_heat), so this is added below if (associated(fluxes%seaice_melt_heat)) then - net_heat(i) = scale * dt_in_T * W_m2_to_H_T * US%QRZ_T_to_W_m2 * & + net_heat(i) = scale * dt_in_T * RZcP_to_H * & ( fluxes%sw(i,j) + (((fluxes%lw(i,j) + fluxes%latent(i,j)) + fluxes%sens(i,j)) + & fluxes%seaice_melt_heat(i,j)) ) !Repeats above code w/ dt=1. for legacy reason - if (do_NHR) net_heat_rate(i) = scale * W_m2_to_H_T * US%QRZ_T_to_W_m2 * & + if (do_NHR) net_heat_rate(i) = scale * RZcP_to_H * & ( fluxes%sw(i,j) + (((fluxes%lw(i,j) + fluxes%latent(i,j)) + fluxes%sens(i,j)) + & fluxes%seaice_melt_heat(i,j))) else - net_heat(i) = scale * dt_in_T * W_m2_to_H_T * US%QRZ_T_to_W_m2 * & + net_heat(i) = scale * dt_in_T * RZcP_to_H * & ( fluxes%sw(i,j) + ((fluxes%lw(i,j) + fluxes%latent(i,j)) + fluxes%sens(i,j)) ) !Repeats above code w/ dt=1. for legacy reason - if (do_NHR) net_heat_rate(i) = scale * W_m2_to_H_T * US%QRZ_T_to_W_m2 * & + if (do_NHR) net_heat_rate(i) = scale * RZcP_to_H * & ( fluxes%sw(i,j) + ((fluxes%lw(i,j) + fluxes%latent(i,j)) + fluxes%sens(i,j)) ) endif @@ -656,12 +653,12 @@ subroutine extractFluxes1d(G, GV, US, fluxes, optics, nsw, j, dt_in_T, & ! endif if (fluxes%num_msg < fluxes%max_msg) then - if (Pen_SW_tot(i) > 1.000001 * W_m2_to_H_T*US%QRZ_T_to_W_m2*scale*dt_in_T*fluxes%sw(i,j)) then + if (Pen_SW_tot(i) > 1.000001 * RZcP_to_H*scale*dt_in_T*fluxes%sw(i,j)) then fluxes%num_msg = fluxes%num_msg + 1 write(mesg,'("Penetrating shortwave of ",1pe17.10, & &" exceeds total shortwave of ",1pe17.10,& &" at ",1pg11.4,"E, "1pg11.4,"N.")') & - Pen_SW_tot(i),W_m2_to_H_T*US%QRZ_T_to_W_m2*scale*dt_in_T * fluxes%sw(i,j),& + Pen_SW_tot(i),RZcP_to_H*scale*dt_in_T * fluxes%sw(i,j),& G%geoLonT(i,j),G%geoLatT(i,j) call MOM_error(WARNING,mesg) endif @@ -675,7 +672,7 @@ subroutine extractFluxes1d(G, GV, US, fluxes, optics, nsw, j, dt_in_T, & ! diagnose non-downwelling SW if (present(nonPenSW)) then - nonPenSW(i) = scale * dt_in_T * W_m2_to_H_T * US%QRZ_T_to_W_m2*fluxes%sw(i,j) - Pen_SW_tot(i) + nonPenSW(i) = scale * dt_in_T * RZcP_to_H * fluxes%sw(i,j) - Pen_SW_tot(i) endif ! Salt fluxes @@ -704,9 +701,9 @@ subroutine extractFluxes1d(G, GV, US, fluxes, optics, nsw, j, dt_in_T, & 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) = -US%Q_to_J_kg*fluxes%C_p * netMassOut(i) * T(i,1) * GV%H_to_RZ / dt_in_T + fluxes%heat_content_massin(i,j) = -fluxes%C_p * netMassOut(i) * T(i,1) * GV%H_to_RZ / dt_in_T else ! net is "out" - fluxes%heat_content_massin(i,j) = US%Q_to_J_kg*fluxes%C_p * ( netMassInout(i) - netMassOut(i) ) * & + fluxes%heat_content_massin(i,j) = fluxes%C_p * ( netMassInout(i) - netMassOut(i) ) * & T(i,1) * GV%H_to_RZ / dt_in_T endif else @@ -719,10 +716,10 @@ subroutine extractFluxes1d(G, GV, US, fluxes, optics, nsw, j, dt_in_T, & 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) = US%Q_to_J_kg*fluxes%C_p * netMassOut(i) * T(i,1) * GV%H_to_RZ / dt_in_T + fluxes%heat_content_massout(i,j) = fluxes%C_p * netMassOut(i) * T(i,1) * GV%H_to_RZ / dt_in_T else ! net is "out" - fluxes%heat_content_massout(i,j) = -US%Q_to_J_kg*fluxes%C_p * ( netMassInout(i) - netMassOut(i) ) * & - T(i,1) * GV%H_to_RZ / dt_in_T + fluxes%heat_content_massout(i,j) = -fluxes%C_p * ( netMassInout(i) - netMassOut(i) ) * & + T(i,1) * GV%H_to_RZ / dt_in_T endif else fluxes%heat_content_massout(i,j) = 0.0 @@ -738,7 +735,7 @@ subroutine extractFluxes1d(G, GV, US, fluxes, optics, nsw, j, dt_in_T, & ! wait until MOM_diabatic_driver.F90. if (associated(fluxes%heat_content_lprec)) then if (fluxes%lprec(i,j) > 0.0) then - fluxes%heat_content_lprec(i,j) = US%Q_to_J_kg*fluxes%C_p*fluxes%lprec(i,j)*T(i,1) + fluxes%heat_content_lprec(i,j) = fluxes%C_p*fluxes%lprec(i,j)*T(i,1) else fluxes%heat_content_lprec(i,j) = 0.0 endif @@ -749,7 +746,7 @@ subroutine extractFluxes1d(G, GV, US, fluxes, optics, nsw, j, dt_in_T, & ! and until we do so fprec is treated like lprec and enters at SST. -AJA if (associated(fluxes%heat_content_fprec)) then if (fluxes%fprec(i,j) > 0.0) then - fluxes%heat_content_fprec(i,j) = US%Q_to_J_kg*fluxes%C_p*fluxes%fprec(i,j)*T(i,1) + fluxes%heat_content_fprec(i,j) = fluxes%C_p*fluxes%fprec(i,j)*T(i,1) else fluxes%heat_content_fprec(i,j) = 0.0 endif @@ -758,7 +755,7 @@ subroutine extractFluxes1d(G, GV, US, fluxes, optics, nsw, j, dt_in_T, & ! Following lprec and fprec, water flux due to sea ice melt (seaice_melt) enters at SST - GMM if (associated(fluxes%heat_content_icemelt)) then if (fluxes%seaice_melt(i,j) > 0.0) then - fluxes%heat_content_icemelt(i,j) = US%Q_to_J_kg*fluxes%C_p*fluxes%seaice_melt(i,j)*T(i,1) + fluxes%heat_content_icemelt(i,j) = fluxes%C_p*fluxes%seaice_melt(i,j)*T(i,1) else fluxes%heat_content_icemelt(i,j) = 0.0 endif @@ -769,7 +766,7 @@ subroutine extractFluxes1d(G, GV, US, fluxes, optics, nsw, j, dt_in_T, & ! vprec < 0 means remove water from ocean; set heat_content_vprec in MOM_diabatic_driver.F90 if (associated(fluxes%heat_content_vprec)) then if (fluxes%vprec(i,j) > 0.0) then - fluxes%heat_content_vprec(i,j) = US%Q_to_J_kg*fluxes%C_p*fluxes%vprec(i,j)*T(i,1) + fluxes%heat_content_vprec(i,j) = fluxes%C_p*fluxes%vprec(i,j)*T(i,1) else fluxes%heat_content_vprec(i,j) = 0.0 endif @@ -783,7 +780,7 @@ subroutine extractFluxes1d(G, GV, US, fluxes, optics, nsw, j, dt_in_T, & ! Condensation is assumed to drop into the ocean at the SST, just like lprec. if (associated(fluxes%heat_content_cond)) then if (fluxes%evap(i,j) > 0.0) then - fluxes%heat_content_cond(i,j) = US%Q_to_J_kg*fluxes%C_p*fluxes%evap(i,j)*T(i,1) + fluxes%heat_content_cond(i,j) = fluxes%C_p*fluxes%evap(i,j)*T(i,1) else fluxes%heat_content_cond(i,j) = 0.0 endif @@ -792,14 +789,14 @@ subroutine extractFluxes1d(G, GV, US, fluxes, optics, nsw, j, dt_in_T, & ! 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 - fluxes%heat_content_lrunoff(i,j) = US%Q_to_J_kg*fluxes%C_p*fluxes%lrunoff(i,j)*T(i,1) + 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 - fluxes%heat_content_frunoff(i,j) = US%Q_to_J_kg*fluxes%C_p*fluxes%frunoff(i,j)*T(i,1) + fluxes%heat_content_frunoff(i,j) = fluxes%C_p*fluxes%frunoff(i,j)*T(i,1) endif endif @@ -1088,22 +1085,22 @@ subroutine MOM_forcing_chksum(mesg, fluxes, G, US, haloshift) haloshift=hshift, scale=RZ_T_conversion) if (associated(fluxes%heat_content_frunoff)) & call hchksum(fluxes%heat_content_frunoff, mesg//" fluxes%heat_content_frunoff", G%HI, & - haloshift=hshift, scale=RZ_T_conversion) + haloshift=hshift, scale=US%QRZ_T_to_W_m2) if (associated(fluxes%heat_content_lprec)) & call hchksum(fluxes%heat_content_lprec, mesg//" fluxes%heat_content_lprec", G%HI, & - haloshift=hshift, scale=RZ_T_conversion) + haloshift=hshift, scale=US%QRZ_T_to_W_m2) if (associated(fluxes%heat_content_fprec)) & call hchksum(fluxes%heat_content_fprec, mesg//" fluxes%heat_content_fprec", G%HI, & - haloshift=hshift, scale=RZ_T_conversion) + haloshift=hshift, scale=US%QRZ_T_to_W_m2) if (associated(fluxes%heat_content_icemelt)) & call hchksum(fluxes%heat_content_icemelt, mesg//" fluxes%heat_content_icemelt", G%HI, & - haloshift=hshift, scale=RZ_T_conversion) + haloshift=hshift, scale=US%QRZ_T_to_W_m2) if (associated(fluxes%heat_content_cond)) & call hchksum(fluxes%heat_content_cond, mesg//" fluxes%heat_content_cond", G%HI, & - haloshift=hshift, scale=RZ_T_conversion) + haloshift=hshift, scale=US%QRZ_T_to_W_m2) if (associated(fluxes%heat_content_massout)) & call hchksum(fluxes%heat_content_massout, mesg//" fluxes%heat_content_massout", G%HI, & - haloshift=hshift, scale=RZ_T_conversion) + haloshift=hshift, scale=US%QRZ_T_to_W_m2) end subroutine MOM_forcing_chksum !> Write out chksums for the driving mechanical forces. @@ -1471,69 +1468,69 @@ subroutine register_forcing_type_diags(Time, diag, US, use_temperature, handles, handles%id_heat_content_frunoff = register_diag_field('ocean_model', 'heat_content_frunoff', & diag%axesT1, Time, 'Heat content (relative to 0C) of solid runoff into ocean', & - 'W m-2', conversion=US%R_to_kg_m3*US%Z_to_m*US%s_to_T, & + 'W m-2', conversion=US%QRZ_T_to_W_m2, & standard_name='temperature_flux_due_to_solid_runoff_expressed_as_heat_flux_into_sea_water') handles%id_heat_content_lrunoff = register_diag_field('ocean_model', 'heat_content_lrunoff', & diag%axesT1, Time, 'Heat content (relative to 0C) of liquid runoff into ocean', & - 'W m-2', conversion=US%R_to_kg_m3*US%Z_to_m*US%s_to_T, & + 'W m-2', conversion=US%QRZ_T_to_W_m2, & standard_name='temperature_flux_due_to_runoff_expressed_as_heat_flux_into_sea_water') handles%id_hfrunoffds = register_diag_field('ocean_model', 'hfrunoffds', & diag%axesT1, Time, 'Heat content (relative to 0C) of liquid+solid runoff into ocean', & - 'W m-2', conversion=US%R_to_kg_m3*US%Z_to_m*US%s_to_T, & + 'W m-2', conversion=US%QRZ_T_to_W_m2, & standard_name='temperature_flux_due_to_runoff_expressed_as_heat_flux_into_sea_water') handles%id_heat_content_lprec = register_diag_field('ocean_model', 'heat_content_lprec', & diag%axesT1,Time,'Heat content (relative to 0degC) of liquid precip entering ocean', & - 'W m-2', conversion=US%R_to_kg_m3*US%Z_to_m*US%s_to_T) + 'W m-2', conversion=US%QRZ_T_to_W_m2) handles%id_heat_content_fprec = register_diag_field('ocean_model', 'heat_content_fprec',& diag%axesT1,Time,'Heat content (relative to 0degC) of frozen prec entering ocean',& - 'W m-2', conversion=US%R_to_kg_m3*US%Z_to_m*US%s_to_T) + 'W m-2', conversion=US%QRZ_T_to_W_m2) handles%id_heat_content_icemelt = register_diag_field('ocean_model', 'heat_content_icemelt',& diag%axesT1,Time,'Heat content (relative to 0degC) of water flux due to sea ice melting/freezing',& - 'W m-2', conversion=US%R_to_kg_m3*US%Z_to_m*US%s_to_T) + 'W m-2', conversion=US%QRZ_T_to_W_m2) handles%id_heat_content_vprec = register_diag_field('ocean_model', 'heat_content_vprec', & diag%axesT1,Time,'Heat content (relative to 0degC) of virtual precip entering ocean',& - 'W m-2', conversion=US%R_to_kg_m3*US%Z_to_m*US%s_to_T) + 'W m-2', conversion=US%QRZ_T_to_W_m2) handles%id_heat_content_cond = register_diag_field('ocean_model', 'heat_content_cond', & diag%axesT1,Time,'Heat content (relative to 0degC) of water condensing into ocean',& - 'W m-2', conversion=US%R_to_kg_m3*US%Z_to_m*US%s_to_T) + 'W m-2', conversion=US%QRZ_T_to_W_m2) handles%id_hfrainds = register_diag_field('ocean_model', 'hfrainds', & diag%axesT1,Time,'Heat content (relative to 0degC) of liquid+frozen precip entering ocean', & - 'W m-2', conversion=US%R_to_kg_m3*US%Z_to_m*US%s_to_T, & + 'W m-2', conversion=US%QRZ_T_to_W_m2, & standard_name='temperature_flux_due_to_rainfall_expressed_as_heat_flux_into_sea_water',& cmor_long_name='Heat Content (relative to 0degC) of Liquid + Frozen Precipitation') handles%id_heat_content_surfwater = register_diag_field('ocean_model', 'heat_content_surfwater',& diag%axesT1, Time, & 'Heat content (relative to 0degC) of net water crossing ocean surface (frozen+liquid)', & - 'W m-2', conversion=US%R_to_kg_m3*US%Z_to_m*US%s_to_T) + 'W m-2', conversion=US%QRZ_T_to_W_m2) handles%id_heat_content_massout = register_diag_field('ocean_model', 'heat_content_massout', & diag%axesT1, Time,'Heat content (relative to 0degC) of net mass leaving ocean ocean via evap and ice form',& - 'W m-2', conversion=US%R_to_kg_m3*US%Z_to_m*US%s_to_T, & + 'W m-2', conversion=US%QRZ_T_to_W_m2, & cmor_field_name='hfevapds', & cmor_standard_name='temperature_flux_due_to_evaporation_expressed_as_heat_flux_out_of_sea_water', & cmor_long_name='Heat Content (relative to 0degC) of Water Leaving Ocean via Evaporation and Ice Formation') handles%id_heat_content_massin = register_diag_field('ocean_model', 'heat_content_massin', & diag%axesT1, Time,'Heat content (relative to 0degC) of net mass entering ocean ocean',& - 'W m-2', conversion=US%R_to_kg_m3*US%Z_to_m*US%s_to_T) + 'W m-2', conversion=US%QRZ_T_to_W_m2) handles%id_net_heat_coupler = register_diag_field('ocean_model', 'net_heat_coupler', & diag%axesT1,Time,'Surface ocean heat flux from SW+LW+latent+sensible+seaice_melt_heat (via the coupler)',& - 'W m-2') + 'W m-2', conversion=US%QRZ_T_to_W_m2) handles%id_net_heat_surface = register_diag_field('ocean_model', 'net_heat_surface',diag%axesT1, Time, & 'Surface ocean heat flux from SW+LW+lat+sens+mass transfer+frazil+restore+seaice_melt_heat or '// & - 'flux adjustments',& - 'W m-2',& + 'flux adjustments', & + 'W m-2', conversion=US%QRZ_T_to_W_m2, & standard_name='surface_downward_heat_flux_in_sea_water', cmor_field_name='hfds', & cmor_standard_name='surface_downward_heat_flux_in_sea_water', & cmor_long_name='Surface ocean heat flux from SW+LW+latent+sensible+masstransfer+frazil+seaice_melt_heat') @@ -1552,7 +1549,7 @@ subroutine register_forcing_type_diags(Time, diag, US, use_temperature, handles, 'W m-2', conversion=US%QRZ_T_to_W_m2) handles%id_LwLatSens = register_diag_field('ocean_model', 'LwLatSens', diag%axesT1, Time, & - 'Combined longwave, latent, and sensible heating at ocean surface', 'W m-2') + 'Combined longwave, latent, and sensible heating at ocean surface', 'W m-2', conversion=US%QRZ_T_to_W_m2) handles%id_lw = register_diag_field('ocean_model', 'LW', diag%axesT1, Time, & 'Longwave radiation flux into ocean', 'W m-2', conversion=US%QRZ_T_to_W_m2, & @@ -2451,63 +2448,63 @@ subroutine forcing_diagnostics(fluxes, sfc_state, G, US, time_end, diag, handles 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 - total_transport = global_area_integral(fluxes%heat_content_lrunoff, G, scale=RZ_T_conversion) + total_transport = global_area_integral(fluxes%heat_content_lrunoff, G, scale=US%QRZ_T_to_W_m2) 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)) & call post_data(handles%id_heat_content_frunoff, fluxes%heat_content_frunoff, diag) if ((handles%id_total_heat_content_frunoff > 0) .and. associated(fluxes%heat_content_frunoff)) then - total_transport = global_area_integral(fluxes%heat_content_frunoff, G, scale=RZ_T_conversion) + total_transport = global_area_integral(fluxes%heat_content_frunoff, G, scale=US%QRZ_T_to_W_m2) call post_data(handles%id_total_heat_content_frunoff, total_transport, diag) endif if ((handles%id_heat_content_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 - total_transport = global_area_integral(fluxes%heat_content_lprec, G, scale=RZ_T_conversion) + total_transport = global_area_integral(fluxes%heat_content_lprec, G, scale=US%QRZ_T_to_W_m2) 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)) & 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 - total_transport = global_area_integral(fluxes%heat_content_fprec, G, scale=RZ_T_conversion) + total_transport = global_area_integral(fluxes%heat_content_fprec, G, scale=US%QRZ_T_to_W_m2) call post_data(handles%id_total_heat_content_fprec, total_transport, diag) endif if ((handles%id_heat_content_icemelt > 0) .and. associated(fluxes%heat_content_icemelt)) & call post_data(handles%id_heat_content_icemelt, fluxes%heat_content_icemelt, diag) if ((handles%id_total_heat_content_icemelt > 0) .and. associated(fluxes%heat_content_icemelt)) then - total_transport = global_area_integral(fluxes%heat_content_icemelt, G, scale=RZ_T_conversion) + total_transport = global_area_integral(fluxes%heat_content_icemelt, G, scale=US%QRZ_T_to_W_m2) call post_data(handles%id_total_heat_content_icemelt, total_transport, diag) endif 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 - total_transport = global_area_integral(fluxes%heat_content_vprec, G, scale=RZ_T_conversion) + total_transport = global_area_integral(fluxes%heat_content_vprec, G, scale=US%QRZ_T_to_W_m2) 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)) & 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 - total_transport = global_area_integral(fluxes%heat_content_cond, G, scale=RZ_T_conversion) + total_transport = global_area_integral(fluxes%heat_content_cond, G, scale=US%QRZ_T_to_W_m2) 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)) & 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 - total_transport = global_area_integral(fluxes%heat_content_massout,G, scale=RZ_T_conversion) + total_transport = global_area_integral(fluxes%heat_content_massout,G, scale=US%QRZ_T_to_W_m2) 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)) & 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 - total_transport = global_area_integral(fluxes%heat_content_massin, G, scale=RZ_T_conversion) + total_transport = global_area_integral(fluxes%heat_content_massin, G, scale=US%QRZ_T_to_W_m2) call post_data(handles%id_total_heat_content_massin, total_transport, diag) endif @@ -2515,19 +2512,19 @@ subroutine forcing_diagnostics(fluxes, sfc_state, G, US, time_end, diag, handles 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) + US%QRZ_T_to_W_m2*fluxes%lw(i,j) - if (associated(fluxes%latent)) res(i,j) = res(i,j) + US%QRZ_T_to_W_m2*fluxes%latent(i,j) - if (associated(fluxes%sens)) res(i,j) = res(i,j) + US%QRZ_T_to_W_m2*fluxes%sens(i,j) - if (associated(fluxes%SW)) res(i,j) = res(i,j) + US%QRZ_T_to_W_m2*fluxes%sw(i,j) - if (associated(fluxes%seaice_melt_heat)) res(i,j) = res(i,j) + US%QRZ_T_to_W_m2*fluxes%seaice_melt_heat(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) + if (associated(fluxes%seaice_melt_heat)) res(i,j) = res(i,j) + fluxes%seaice_melt_heat(i,j) enddo ; enddo if (handles%id_net_heat_coupler > 0) call post_data(handles%id_net_heat_coupler, res, diag) if (handles%id_total_net_heat_coupler > 0) then - total_transport = global_area_integral(res,G) + total_transport = global_area_integral(res, G, scale=US%QRZ_T_to_W_m2) call post_data(handles%id_total_net_heat_coupler, total_transport, diag) endif if (handles%id_net_heat_coupler_ga > 0) then - ave_flux = global_area_mean(res,G) + ave_flux = global_area_mean(res, G, scale=US%QRZ_T_to_W_m2) call post_data(handles%id_net_heat_coupler_ga, ave_flux, diag) endif endif @@ -2536,42 +2533,42 @@ subroutine forcing_diagnostics(fluxes, sfc_state, G, US, time_end, diag, handles 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) + US%QRZ_T_to_W_m2*fluxes%lw(i,j) - if (associated(fluxes%latent)) res(i,j) = res(i,j) + US%QRZ_T_to_W_m2*fluxes%latent(i,j) - if (associated(fluxes%sens)) res(i,j) = res(i,j) + US%QRZ_T_to_W_m2*fluxes%sens(i,j) - if (associated(fluxes%SW)) res(i,j) = res(i,j) + US%QRZ_T_to_W_m2*fluxes%sw(i,j) - if (associated(fluxes%seaice_melt_heat)) res(i,j) = res(i,j) + US%QRZ_T_to_W_m2*fluxes%seaice_melt_heat(i,j) - if (associated(sfc_state%frazil)) res(i,j) = res(i,j) + sfc_state%frazil(i,j) * I_dt + 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%seaice_melt_heat)) res(i,j) = res(i,j) + fluxes%seaice_melt_heat(i,j) + if (associated(sfc_state%frazil)) res(i,j) = res(i,j) + US%W_m2_to_QRZ_T*sfc_state%frazil(i,j) * I_dt !if (associated(sfc_state%TempXpme)) then ! res(i,j) = res(i,j) + sfc_state%TempXpme(i,j) * US%Q_to_J_kg*fluxes%C_p * I_dt !else if (associated(fluxes%heat_content_lrunoff)) & - res(i,j) = res(i,j) + RZ_T_conversion*fluxes%heat_content_lrunoff(i,j) + res(i,j) = res(i,j) + fluxes%heat_content_lrunoff(i,j) if (associated(fluxes%heat_content_frunoff)) & - res(i,j) = res(i,j) + RZ_T_conversion*fluxes%heat_content_frunoff(i,j) + res(i,j) = res(i,j) + fluxes%heat_content_frunoff(i,j) if (associated(fluxes%heat_content_lprec)) & - res(i,j) = res(i,j) + RZ_T_conversion*fluxes%heat_content_lprec(i,j) + res(i,j) = res(i,j) + fluxes%heat_content_lprec(i,j) if (associated(fluxes%heat_content_fprec)) & - res(i,j) = res(i,j) + RZ_T_conversion*fluxes%heat_content_fprec(i,j) + res(i,j) = res(i,j) + fluxes%heat_content_fprec(i,j) if (associated(fluxes%heat_content_icemelt)) & - res(i,j) = res(i,j) + RZ_T_conversion*fluxes%heat_content_icemelt(i,j) + res(i,j) = res(i,j) + fluxes%heat_content_icemelt(i,j) if (associated(fluxes%heat_content_vprec)) & - res(i,j) = res(i,j) + RZ_T_conversion*fluxes%heat_content_vprec(i,j) + res(i,j) = res(i,j) + fluxes%heat_content_vprec(i,j) if (associated(fluxes%heat_content_cond)) & - res(i,j) = res(i,j) + RZ_T_conversion*fluxes%heat_content_cond(i,j) + res(i,j) = res(i,j) + fluxes%heat_content_cond(i,j) if (associated(fluxes%heat_content_massout)) & - res(i,j) = res(i,j) + RZ_T_conversion*fluxes%heat_content_massout(i,j) + res(i,j) = res(i,j) + fluxes%heat_content_massout(i,j) !endif - if (associated(fluxes%heat_added)) res(i,j) = res(i,j) + US%QRZ_T_to_W_m2*fluxes%heat_added(i,j) + if (associated(fluxes%heat_added)) res(i,j) = res(i,j) + fluxes%heat_added(i,j) enddo ; enddo if (handles%id_net_heat_surface > 0) call post_data(handles%id_net_heat_surface, res, diag) if (handles%id_total_net_heat_surface > 0) then - total_transport = global_area_integral(res, G) + total_transport = global_area_integral(res, G, scale=US%QRZ_T_to_W_m2) call post_data(handles%id_total_net_heat_surface, total_transport, diag) endif if (handles%id_net_heat_surface_ga > 0) then - ave_flux = global_area_mean(res, G) + ave_flux = global_area_mean(res, G, scale=US%QRZ_T_to_W_m2) call post_data(handles%id_net_heat_surface_ga, ave_flux, diag) endif endif @@ -2594,7 +2591,7 @@ subroutine forcing_diagnostics(fluxes, sfc_state, G, US, time_end, diag, handles enddo ; enddo if (handles%id_heat_content_surfwater > 0) call post_data(handles%id_heat_content_surfwater, res, diag) if (handles%id_total_heat_content_surfwater > 0) then - total_transport = global_area_integral(res, G, scale=RZ_T_conversion) + total_transport = global_area_integral(res, G, scale=US%QRZ_T_to_W_m2) call post_data(handles%id_total_heat_content_surfwater, total_transport, diag) endif endif @@ -2623,7 +2620,7 @@ subroutine forcing_diagnostics(fluxes, sfc_state, G, US, time_end, diag, handles 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) = US%QRZ_T_to_W_m2*((fluxes%lw(i,j) + fluxes%latent(i,j)) + fluxes%sens(i,j)) + 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 @@ -2631,18 +2628,18 @@ subroutine forcing_diagnostics(fluxes, sfc_state, G, US, time_end, diag, handles 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) = US%QRZ_T_to_W_m2*((fluxes%lw(i,j) + fluxes%latent(i,j)) + fluxes%sens(i,j)) + res(i,j) = (fluxes%lw(i,j) + fluxes%latent(i,j)) + fluxes%sens(i,j) enddo ; enddo - total_transport = global_area_integral(res,G) + total_transport = global_area_integral(res, G, scale=US%QRZ_T_to_W_m2) 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 do j=js,je ; do i=is,ie - res(i,j) = US%QRZ_T_to_W_m2*((fluxes%lw(i,j) + fluxes%latent(i,j)) + fluxes%sens(i,j)) + res(i,j) = ((fluxes%lw(i,j) + fluxes%latent(i,j)) + fluxes%sens(i,j)) enddo ; enddo - ave_flux = global_area_mean(res,G) + ave_flux = global_area_mean(res, G, scale=US%QRZ_T_to_W_m2) call post_data(handles%id_LwLatSens_ga, ave_flux, diag) endif diff --git a/src/diagnostics/MOM_sum_output.F90 b/src/diagnostics/MOM_sum_output.F90 index f094fcc6fc..9e4c7af74a 100644 --- a/src/diagnostics/MOM_sum_output.F90 +++ b/src/diagnostics/MOM_sum_output.F90 @@ -1012,7 +1012,7 @@ subroutine accumulate_net_input(fluxes, sfc_state, tv, dt, G, US, CS) ! 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 -! heat_in(i,j) = heat_in(i,j) + dt*RZL2_to_kg*G%areaT(i,j) * & +! heat_in(i,j) = heat_in(i,j) + dt*US%T_to_s*US%L_to_m**2*US%QRZ_T_to_W_m2*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) & ! + (fluxes%heat_content_cond(i,j) + (fluxes%heat_content_vprec(i,j) & diff --git a/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 b/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 index deaf4634ab..c910433172 100644 --- a/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 +++ b/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 @@ -1122,7 +1122,7 @@ subroutine mixedlayer_convection(h, d_eb, htot, Ttot, Stot, uhtot, vhtot, & Conv_En(i) = 0.0 ; dKE_FC(i) = 0.0 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_RZ * US%Q_to_J_kg*fluxes%C_p * Idt + T_precip * netMassIn(i) * GV%H_to_RZ * fluxes%C_p * Idt if (associated(tv%TempxPmE)) tv%TempxPmE(i,j) = tv%TempxPmE(i,j) + & T_precip * netMassIn(i) * GV%H_to_RZ else ! This is a massless column, but zero out the summed variables anyway for safety. @@ -1173,12 +1173,12 @@ subroutine mixedlayer_convection(h, d_eb, htot, Ttot, Stot, uhtot, vhtot, & d_eb(i,k) = d_eb(i,k) - h_evap ! smg: when resolve the A=B code, we will set - ! heat_content_massout = heat_content_massout - T(i,k)*h_evap*GV%H_to_RZ*US%Q_to_J_kg*fluxes%C_p*Idt + ! heat_content_massout = heat_content_massout - T(i,k)*h_evap*GV%H_to_RZ*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)) & fluxes%heat_content_massout(i,j) = fluxes%heat_content_massout(i,j) - & - T(i,k)*h_evap*GV%H_to_RZ * US%Q_to_J_kg*fluxes%C_p * Idt + T(i,k)*h_evap*GV%H_to_RZ * fluxes%C_p * Idt if (associated(tv%TempxPmE)) tv%TempxPmE(i,j) = tv%TempxPmE(i,j) - & T(i,k)*h_evap*GV%H_to_RZ diff --git a/src/parameterizations/vertical/MOM_diabatic_aux.F90 b/src/parameterizations/vertical/MOM_diabatic_aux.F90 index b8a0031686..626b460454 100644 --- a/src/parameterizations/vertical/MOM_diabatic_aux.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_aux.F90 @@ -1119,10 +1119,10 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t ! Diagnostics of heat content associated with mass fluxes 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_RZ * US%Q_to_J_kg*fluxes%C_p * Idt + T2d(i,k) * max(0.,dThickness) * GV%H_to_RZ * fluxes%C_p * Idt 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_RZ * US%Q_to_J_kg*fluxes%C_p * Idt + T2d(i,k) * min(0.,dThickness) * GV%H_to_RZ * fluxes%C_p * Idt if (associated(tv%TempxPmE)) tv%TempxPmE(i,j) = tv%TempxPmE(i,j) + & T2d(i,k) * dThickness * GV%H_to_RZ @@ -1202,10 +1202,10 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t ! Diagnostics of heat content associated with mass fluxes 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_RZ * US%Q_to_J_kg*fluxes%C_p * Idt + T2d(i,k) * max(0.,dThickness) * GV%H_to_RZ * fluxes%C_p * Idt 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_RZ * US%Q_to_J_kg*fluxes%C_p * Idt + T2d(i,k) * min(0.,dThickness) * GV%H_to_RZ * fluxes%C_p * Idt if (associated(tv%TempxPmE)) tv%TempxPmE(i,j) = tv%TempxPmE(i,j) + & T2d(i,k) * dThickness * GV%H_to_RZ From 1d4f977ec5806e0215b242521a761e26b674c07f Mon Sep 17 00:00:00 2001 From: Matthew Harrison Date: Fri, 21 Feb 2020 14:48:42 -0500 Subject: [PATCH 073/316] fix comments --- src/tracer/MOM_tracer_Z_init.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/tracer/MOM_tracer_Z_init.F90 b/src/tracer/MOM_tracer_Z_init.F90 index 875af6b549..f09c0e51c8 100644 --- a/src/tracer/MOM_tracer_Z_init.F90 +++ b/src/tracer/MOM_tracer_Z_init.F90 @@ -282,7 +282,7 @@ subroutine tracer_z_init_array(tr_in, z_edges, e, nkml, nkbl, land_fill, wet, nl eps_z, tr) real, dimension(:,:,:), intent(in) :: tr_in !< The z-space array of tracer concentrations that is read in. real, dimension(size(tr_in,3)+1), intent(in) :: z_edges !< The depths of the cell edges in the input z* data - !! [Z ~> m or m] + !! [Z ~> m or m] integer, intent(in) :: nlay !< The number of vertical layers in the target grid real, dimension(size(tr_in,1),size(tr_in,2),nlay+1), & intent(in) :: e !< The depths of the target layer interfaces [Z ~> m or m] @@ -293,7 +293,7 @@ subroutine tracer_z_init_array(tr_in, z_edges, e, nkml, nkbl, land_fill, wet, nl intent(in) :: wet !< The wet mask for the source data (valid points) integer, dimension(size(tr_in,1),size(tr_in,2)), & intent(in) :: nlevs !< The number of input levels with valid data - real, intent(in) :: eps_z ! A negligibly thin layer thickness [Z ~> m]. + real, intent(in) :: eps_z !< A negligibly thin layer thickness [Z ~> m]. real, dimension(size(tr_in,1),size(tr_in,2),nlay), intent(out) :: tr !< tracers in layer space ! Local variables From 1614b931e1bbb8cbfc856dddaf2e9c60f6c68c27 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 21 Feb 2020 17:48:50 -0500 Subject: [PATCH 074/316] +Rescaled units of tv%frazil to [Q R Z] Rescaled the units of tv%frazil to [Q R Z] for dimensional consistency verification. However, the units of sfc%frazil are still in [J m-2], so sfc%frazil is no longer a pointer to tv%frazil, bur instead is an allocatable array that is copied into; this also requires several associated statements to be changed into allocated statements. Also renamed dt_in_T to dt in MOM_forcing_type.F90. All answers are bitwise identical, although there have been changes to the nature of the one element in a transparent public type that is used in the various versions of the coupler interface code. --- config_src/coupled_driver/ocean_model_MOM.F90 | 16 ++--- config_src/mct_driver/mom_ocean_model_mct.F90 | 2 +- .../nuopc_driver/mom_ocean_model_nuopc.F90 | 2 +- src/core/MOM.F90 | 19 ++++-- src/core/MOM_checksum_packages.F90 | 11 +-- src/core/MOM_forcing_type.F90 | 68 +++++++++---------- src/core/MOM_variables.F90 | 29 ++++---- src/diagnostics/MOM_diagnostics.F90 | 3 +- src/diagnostics/MOM_sum_output.F90 | 2 +- src/ice_shelf/MOM_marine_ice.F90 | 7 +- .../vertical/MOM_diabatic_aux.F90 | 14 ++-- 11 files changed, 92 insertions(+), 81 deletions(-) diff --git a/config_src/coupled_driver/ocean_model_MOM.F90 b/config_src/coupled_driver/ocean_model_MOM.F90 index d6e2bc31bc..407a11a0c3 100644 --- a/config_src/coupled_driver/ocean_model_MOM.F90 +++ b/config_src/coupled_driver/ocean_model_MOM.F90 @@ -787,13 +787,13 @@ subroutine initialize_ocean_public_type(input_domain, Ocean_sfc, diag, maskmap, 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%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 @@ -872,7 +872,7 @@ subroutine convert_state_to_ocean_type(sfc_state, Ocean_sfc, G, US, patm, press_ enddo ; enddo endif - if (associated(sfc_state%frazil)) then + if (allocated(sfc_state%frazil)) then do j=jsc_bnd,jec_bnd ; do i=isc_bnd,iec_bnd Ocean_sfc%frazil(i,j) = sfc_state%frazil(i+i0,j+j0) enddo ; enddo diff --git a/config_src/mct_driver/mom_ocean_model_mct.F90 b/config_src/mct_driver/mom_ocean_model_mct.F90 index a62e421723..8b65f056cd 100644 --- a/config_src/mct_driver/mom_ocean_model_mct.F90 +++ b/config_src/mct_driver/mom_ocean_model_mct.F90 @@ -912,7 +912,7 @@ subroutine convert_state_to_ocean_type(sfc_state, Ocean_sfc, G, US, patm, press_ enddo ; enddo endif - if (associated(sfc_state%frazil)) then + if (allocated(sfc_state%frazil)) then do j=jsc_bnd,jec_bnd ; do i=isc_bnd,iec_bnd Ocean_sfc%frazil(i,j) = sfc_state%frazil(i+i0,j+j0) enddo ; enddo diff --git a/config_src/nuopc_driver/mom_ocean_model_nuopc.F90 b/config_src/nuopc_driver/mom_ocean_model_nuopc.F90 index f584a68a36..9c56018bd9 100644 --- a/config_src/nuopc_driver/mom_ocean_model_nuopc.F90 +++ b/config_src/nuopc_driver/mom_ocean_model_nuopc.F90 @@ -907,7 +907,7 @@ subroutine convert_state_to_ocean_type(sfc_state, Ocean_sfc, G, US, patm, press_ enddo ; enddo endif - if (associated(sfc_state%frazil)) then + if (allocated(sfc_state%frazil)) then do j=jsc_bnd,jec_bnd ; do i=isc_bnd,iec_bnd Ocean_sfc%frazil(i,j) = sfc_state%frazil(i+i0,j+j0) enddo ; enddo diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index 0a7ea529aa..0557d6042c 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -1079,8 +1079,8 @@ subroutine step_MOM_tracer_dyn(CS, G, GV, US, h, Time_local) haloshift=0, scale=GV%H_to_m*US%L_to_m**2) if (associated(CS%tv%T)) call hchksum(CS%tv%T, "Pre-advection T", G%HI, haloshift=1) if (associated(CS%tv%S)) call hchksum(CS%tv%S, "Pre-advection S", G%HI, haloshift=1) - if (associated(CS%tv%frazil)) call hchksum(CS%tv%frazil, & - "Pre-advection frazil", G%HI, haloshift=0) + if (associated(CS%tv%frazil)) call hchksum(CS%tv%frazil, "Pre-advection frazil", G%HI, haloshift=0, & + scale=G%US%Q_to_J_kg*G%US%R_to_kg_m3*G%US%Z_to_m) if (associated(CS%tv%salt_deficit)) call hchksum(CS%tv%salt_deficit, & "Pre-advection salt deficit", G%HI, haloshift=0, scale=US%R_to_kg_m3*US%Z_to_m) ! call MOM_thermo_chksum("Pre-advection ", CS%tv, G, US) @@ -1270,8 +1270,8 @@ subroutine step_MOM_thermo(CS, G, GV, US, u, v, h, tv, fluxes, dtdia, & ! h, CS%uhtr, CS%vhtr, G, GV, haloshift=1) if (associated(tv%T)) call hchksum(tv%T, "Post-diabatic T", G%HI, haloshift=1) if (associated(tv%S)) call hchksum(tv%S, "Post-diabatic S", G%HI, haloshift=1) - if (associated(tv%frazil)) call hchksum(tv%frazil, & - "Post-diabatic frazil", G%HI, haloshift=0) + if (associated(tv%frazil)) call hchksum(tv%frazil, "Post-diabatic frazil", G%HI, haloshift=0, & + scale=G%US%Q_to_J_kg*G%US%R_to_kg_m3*G%US%Z_to_m) if (associated(tv%salt_deficit)) call hchksum(tv%salt_deficit, & "Post-diabatic salt deficit", G%HI, haloshift=0, scale=US%R_to_kg_m3*US%Z_to_m) ! call MOM_thermo_chksum("Post-diabatic ", tv, G, US) @@ -2766,9 +2766,9 @@ subroutine extract_surface_state(CS, sfc_state) if (.not.sfc_state%arrays_allocated) then ! Consider using a run-time flag to determine whether to do the vertical ! integrals, since the 3-d sums are not negligible in cost. - call allocate_surface_state(sfc_state, G, use_temperature, do_integrals=.true.) + call allocate_surface_state(sfc_state, G, use_temperature, do_integrals=.true., & + omit_frazil=.not.associated(CS%tv%frazil)) endif - sfc_state%frazil => CS%tv%frazil sfc_state%T_is_conT = CS%tv%T_is_conT sfc_state%S_is_absS = CS%tv%S_is_absS @@ -2776,6 +2776,10 @@ subroutine extract_surface_state(CS, sfc_state) sfc_state%sea_lev(i,j) = CS%ave_ssh_ibc(i,j) enddo ; enddo + if (allocated(sfc_state%frazil) .and. associated(CS%tv%frazil)) then ; do j=js,je ; do i=is,ie + sfc_state%frazil(i,j) = US%Q_to_J_kg*US%R_to_kg_m3*US%Z_to_m * CS%tv%frazil(i,j) + enddo ; enddo ; endif + ! copy Hml into sfc_state, so that caps can access it if (associated(CS%Hml)) then do j=js,je ; do i=is,ie @@ -2799,7 +2803,8 @@ subroutine extract_surface_state(CS, sfc_state) H_rescale = 1.0 ; if (CS%answers_2018) H_rescale = GV%H_to_Z depth_ml = CS%Hmix if (.not.CS%answers_2018) depth_ml = CS%Hmix*GV%Z_to_H - ! Determine the mean tracer properties of the uppermost depth_ml fluid. + ! Determine the mean tracer properties of the uppermost depth_ml fluid. + !$OMP parallel do default(shared) private(depth,dh) do j=js,je do i=is,ie diff --git a/src/core/MOM_checksum_packages.F90 b/src/core/MOM_checksum_packages.F90 index 659ca478ed..d0df64c015 100644 --- a/src/core/MOM_checksum_packages.F90 +++ b/src/core/MOM_checksum_packages.F90 @@ -129,11 +129,12 @@ subroutine MOM_thermo_chksum(mesg, tv, G, US, haloshift) is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke hs=1; if (present(haloshift)) hs=haloshift - if (associated(tv%T)) call hchksum(tv%T, mesg//" T",G%HI,haloshift=hs) - if (associated(tv%S)) call hchksum(tv%S, mesg//" S",G%HI,haloshift=hs) - if (associated(tv%frazil)) call hchksum(tv%frazil, mesg//" frazil",G%HI,haloshift=hs) + if (associated(tv%T)) call hchksum(tv%T, mesg//" T", G%HI, haloshift=hs) + if (associated(tv%S)) call hchksum(tv%S, mesg//" S", G%HI, haloshift=hs) + if (associated(tv%frazil)) call hchksum(tv%frazil, mesg//" frazil", G%HI, haloshift=hs, & + scale=G%US%Q_to_J_kg*G%US%R_to_kg_m3*G%US%Z_to_m) if (associated(tv%salt_deficit)) & - call hchksum(tv%salt_deficit, mesg//" salt deficit",G%HI,haloshift=hs, scale=US%R_to_kg_m3*US%Z_to_m) + call hchksum(tv%salt_deficit, mesg//" salt deficit", G%HI, haloshift=hs, scale=US%R_to_kg_m3*US%Z_to_m) end subroutine MOM_thermo_chksum @@ -163,7 +164,7 @@ subroutine MOM_surface_chksum(mesg, sfc, G, haloshift, symmetric) if (allocated(sfc%u) .and. allocated(sfc%v)) & call uvchksum(mesg//" SSU", sfc%u, sfc%v, G%HI, haloshift=hs, symmetric=sym) ! if (allocated(sfc%salt_deficit)) call hchksum(sfc%salt_deficit, mesg//" salt deficit",G%HI,haloshift=hs) - if (associated(sfc%frazil)) call hchksum(sfc%frazil, mesg//" frazil",G%HI,haloshift=hs) + if (allocated(sfc%frazil)) call hchksum(sfc%frazil, mesg//" frazil", G%HI, haloshift=hs) end subroutine MOM_surface_chksum diff --git a/src/core/MOM_forcing_type.F90 b/src/core/MOM_forcing_type.F90 index 46f7530972..463d825fa3 100644 --- a/src/core/MOM_forcing_type.F90 +++ b/src/core/MOM_forcing_type.F90 @@ -338,7 +338,7 @@ module MOM_forcing_type !! for optimization purposes. The 2d (i,j) wrapper is the next subroutine below. !! This routine multiplies fluxes by dt, so that the result is an accumulation of fluxes !! over a time step. -subroutine extractFluxes1d(G, GV, US, fluxes, optics, nsw, j, dt_in_T, & +subroutine extractFluxes1d(G, GV, US, fluxes, optics, nsw, j, dt, & FluxRescaleDepth, useRiverHeatContent, useCalvingHeatContent, & h, T, netMassInOut, netMassOut, net_heat, net_salt, pen_SW_bnd, tv, & aggregate_FW, nonpenSW, netmassInOut_rate, net_Heat_Rate, & @@ -352,7 +352,7 @@ subroutine extractFluxes1d(G, GV, US, fluxes, optics, nsw, j, dt_in_T, & 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_in_T !< The time step for these fluxes [T ~> s] + real, intent(in) :: dt !< The time step for these fluxes [T ~> s] real, intent(in) :: FluxRescaleDepth !< min ocean depth before fluxes !! are scaled away [H ~> m or kg m-2] logical, intent(in) :: useRiverHeatContent !< logical for river heat content @@ -497,7 +497,7 @@ subroutine extractFluxes1d(G, GV, US, fluxes, optics, nsw, j, dt_in_T, & Pen_sw_tot(i) = 0.0 if (nsw >= 1) then do n=1,nsw - Pen_SW_bnd(n,i) = RZcP_to_H*scale*dt_in_T * max(0.0, Pen_SW_bnd(n,i)) + Pen_SW_bnd(n,i) = RZcP_to_H*scale*dt * max(0.0, Pen_SW_bnd(n,i)) Pen_sw_tot(i) = Pen_sw_tot(i) + Pen_SW_bnd(n,i) enddo else @@ -517,7 +517,7 @@ subroutine extractFluxes1d(G, GV, US, fluxes, optics, nsw, j, dt_in_T, & endif ! net volume/mass of liquid and solid passing through surface boundary fluxes - netMassInOut(i) = dt_in_T * (scale * & + netMassInOut(i) = dt * (scale * & (((((( fluxes%lprec(i,j) & + fluxes%fprec(i,j) ) & + fluxes%evap(i,j) ) & @@ -543,7 +543,7 @@ subroutine extractFluxes1d(G, GV, US, fluxes, optics, nsw, j, dt_in_T, & ! 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_in_T * (scale * fluxes%salt_flux(i,j)) + 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 @@ -569,7 +569,7 @@ subroutine extractFluxes1d(G, GV, US, fluxes, optics, nsw, j, dt_in_T, & ! in which case heat_content_vprec is computed in MOM_diabatic_driver.F90. if (fluxes%vprec(i,j) < 0.0) netMassOut(i) = netMassOut(i) + fluxes%vprec(i,j) - netMassOut(i) = dt_in_T * scale * netMassOut(i) + netMassOut(i) = dt * scale * netMassOut(i) ! convert to H units (Bouss=meter or non-Bouss=kg/m^2) netMassInOut(i) = GV%RZ_to_H * netMassInOut(i) @@ -581,7 +581,7 @@ subroutine extractFluxes1d(G, GV, US, fluxes, optics, nsw, j, dt_in_T, & ! CIME provides heat flux from snow&ice melt (seaice_melt_heat), so this is added below if (associated(fluxes%seaice_melt_heat)) then - net_heat(i) = scale * dt_in_T * RZcP_to_H * & + net_heat(i) = scale * dt * RZcP_to_H * & ( fluxes%sw(i,j) + (((fluxes%lw(i,j) + fluxes%latent(i,j)) + fluxes%sens(i,j)) + & fluxes%seaice_melt_heat(i,j)) ) !Repeats above code w/ dt=1. for legacy reason @@ -589,7 +589,7 @@ subroutine extractFluxes1d(G, GV, US, fluxes, optics, nsw, j, dt_in_T, & ( fluxes%sw(i,j) + (((fluxes%lw(i,j) + fluxes%latent(i,j)) + fluxes%sens(i,j)) + & fluxes%seaice_melt_heat(i,j))) else - net_heat(i) = scale * dt_in_T * RZcP_to_H * & + net_heat(i) = scale * dt * RZcP_to_H * & ( fluxes%sw(i,j) + ((fluxes%lw(i,j) + fluxes%latent(i,j)) + fluxes%sens(i,j)) ) !Repeats above code w/ dt=1. for legacy reason if (do_NHR) net_heat_rate(i) = scale * RZcP_to_H * & @@ -598,7 +598,7 @@ subroutine extractFluxes1d(G, GV, US, fluxes, optics, nsw, j, dt_in_T, & ! Add heat flux from surface damping (restoring) (K * H) or flux adjustments. if (associated(fluxes%heat_added)) then - net_heat(i) = net_heat(i) + (scale * (dt_in_T * QRZ_to_H)) * fluxes%heat_added(i,j) + net_heat(i) = net_heat(i) + (scale * (dt * QRZ_to_H)) * fluxes%heat_added(i,j) if (do_NHR) net_heat_rate(i) = net_heat_rate(i) + (scale * QRZ_to_H) * fluxes%heat_added(i,j) endif @@ -606,15 +606,15 @@ subroutine extractFluxes1d(G, GV, US, fluxes, optics, nsw, j, dt_in_T, & ! flux type). Runoff is otherwise added with a temperature of SST. if (useRiverHeatContent) then ! remove lrunoff*SST here, to counteract its addition elsewhere - net_heat(i) = (net_heat(i) + (scale*(dt_in_T * RZcP_to_H)) * fluxes%heat_content_lrunoff(i,j)) - & - (GV%RZ_to_H * (scale * dt_in_T)) * fluxes%lrunoff(i,j) * T(i,1) + net_heat(i) = (net_heat(i) + (scale*(dt * RZcP_to_H)) * fluxes%heat_content_lrunoff(i,j)) - & + (GV%RZ_to_H * (scale * dt)) * fluxes%lrunoff(i,j) * T(i,1) !BGR-Jul 5, 2017{ !Intentionally neglect the following contribution to rate for legacy reasons. !if (do_NHR) net_heat_rate(i) = (net_heat_rate(i) + (scale*RZcP_to_H) * fluxes%heat_content_lrunoff(i,j)) - & ! (GV%RZ_to_H * (scale)) * fluxes%lrunoff(i,j) * T(i,1) !}BGR if (calculate_diags .and. associated(tv%TempxPmE)) then - tv%TempxPmE(i,j) = tv%TempxPmE(i,j) + (scale * dt_in_T) * & + 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 endif @@ -623,15 +623,15 @@ subroutine extractFluxes1d(G, GV, US, fluxes, optics, nsw, j, dt_in_T, & ! flux type). Calving is otherwise added with a temperature of SST. if (useCalvingHeatContent) then ! remove frunoff*SST here, to counteract its addition elsewhere - net_heat(i) = net_heat(i) + (scale*(dt_in_T * RZcP_to_H)) * fluxes%heat_content_frunoff(i,j) - & - (GV%RZ_to_H * (scale * dt_in_T)) * fluxes%frunoff(i,j) * T(i,1) + net_heat(i) = net_heat(i) + (scale*(dt * RZcP_to_H)) * fluxes%heat_content_frunoff(i,j) - & + (GV%RZ_to_H * (scale * dt)) * fluxes%frunoff(i,j) * T(i,1) !BGR-Jul 5, 2017{ !Intentionally neglect the following contribution to rate for legacy reasons. ! if (do_NHR) net_heat_rate(i) = net_heat_rate(i) + (scale*RZcP_to_H) * fluxes%heat_content_frunoff(i,j) - & ! (GV%RZ_to_H * scale) * fluxes%frunoff(i,j) * T(i,1) !}BGR if (calculate_diags .and. associated(tv%TempxPmE)) then - tv%TempxPmE(i,j) = tv%TempxPmE(i,j) + (scale * dt_in_T) * & + 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 endif @@ -646,19 +646,19 @@ subroutine extractFluxes1d(G, GV, US, fluxes, optics, nsw, j, dt_in_T, & ! 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 -! net_heat(i) = net_heat(i) + scale * dt_in_T * RZcP_to_H * & +! net_heat(i) = net_heat(i) + scale * dt * RZcP_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) + & ! (fluxes%heat_content_cond(i,j) + fluxes%heat_content_vprec(i,j)))))) ! endif if (fluxes%num_msg < fluxes%max_msg) then - if (Pen_SW_tot(i) > 1.000001 * RZcP_to_H*scale*dt_in_T*fluxes%sw(i,j)) then + if (Pen_SW_tot(i) > 1.000001 * RZcP_to_H*scale*dt*fluxes%sw(i,j)) then fluxes%num_msg = fluxes%num_msg + 1 write(mesg,'("Penetrating shortwave of ",1pe17.10, & &" exceeds total shortwave of ",1pe17.10,& &" at ",1pg11.4,"E, "1pg11.4,"N.")') & - Pen_SW_tot(i),RZcP_to_H*scale*dt_in_T * fluxes%sw(i,j),& + Pen_SW_tot(i), RZcP_to_H*scale*dt * fluxes%sw(i,j), & G%geoLonT(i,j),G%geoLatT(i,j) call MOM_error(WARNING,mesg) endif @@ -672,7 +672,7 @@ subroutine extractFluxes1d(G, GV, US, fluxes, optics, nsw, j, dt_in_T, & ! diagnose non-downwelling SW if (present(nonPenSW)) then - nonPenSW(i) = scale * dt_in_T * RZcP_to_H * fluxes%sw(i,j) - Pen_SW_tot(i) + nonPenSW(i) = scale * dt * RZcP_to_H * fluxes%sw(i,j) - Pen_SW_tot(i) endif ! Salt fluxes @@ -682,7 +682,7 @@ subroutine extractFluxes1d(G, GV, US, fluxes, optics, nsw, j, dt_in_T, & ! Boussinesq: (ppt * m) ! non-Bouss: (g/m^2) if (associated(fluxes%salt_flux)) then - Net_salt(i) = (scale * dt_in_T * (1000.0 * fluxes%salt_flux(i,j))) * GV%RZ_to_H + Net_salt(i) = (scale * dt * (1000.0 * fluxes%salt_flux(i,j))) * GV%RZ_to_H !Repeat above code for 'rate' term if (do_NSR) Net_salt_rate(i) = (scale * 1. * (1000.0 * fluxes%salt_flux(i,j))) * GV%RZ_to_H endif @@ -701,10 +701,10 @@ subroutine extractFluxes1d(G, GV, US, fluxes, optics, nsw, j, dt_in_T, & 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_RZ / dt_in_T + fluxes%heat_content_massin(i,j) = -fluxes%C_p * netMassOut(i) * T(i,1) * GV%H_to_RZ / dt else ! net is "out" fluxes%heat_content_massin(i,j) = fluxes%C_p * ( netMassInout(i) - netMassOut(i) ) * & - T(i,1) * GV%H_to_RZ / dt_in_T + T(i,1) * GV%H_to_RZ / dt endif else fluxes%heat_content_massin(i,j) = 0. @@ -716,10 +716,10 @@ subroutine extractFluxes1d(G, GV, US, fluxes, optics, nsw, j, dt_in_T, & 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_RZ / dt_in_T + fluxes%heat_content_massout(i,j) = fluxes%C_p * netMassOut(i) * T(i,1) * GV%H_to_RZ / dt else ! net is "out" fluxes%heat_content_massout(i,j) = -fluxes%C_p * ( netMassInout(i) - netMassOut(i) ) * & - T(i,1) * GV%H_to_RZ / dt_in_T + T(i,1) * GV%H_to_RZ / dt endif else fluxes%heat_content_massout(i,j) = 0.0 @@ -810,7 +810,7 @@ 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, US, fluxes, optics, nsw, dt_in_T, FluxRescaleDepth, & +subroutine extractFluxes2d(G, GV, US, fluxes, optics, nsw, dt, FluxRescaleDepth, & useRiverHeatContent, useCalvingHeatContent, h, T, & netMassInOut, netMassOut, net_heat, Net_salt, Pen_SW_bnd, tv, & aggregate_FW) @@ -821,7 +821,7 @@ subroutine extractFluxes2d(G, GV, US, fluxes, optics, nsw, dt_in_T, FluxRescaleD 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_in_T !< The time step for these fluxes [T ~> s] + real, intent(in) :: dt !< The time step for these fluxes [T ~> s] real, intent(in) :: FluxRescaleDepth !< min ocean depth before fluxes !! are scaled away [H ~> m or kg m-2] logical, intent(in) :: useRiverHeatContent !< logical for river heat content @@ -856,12 +856,12 @@ subroutine extractFluxes2d(G, GV, US, fluxes, optics, nsw, dt_in_T, FluxRescaleD logical, intent(in) :: aggregate_FW !< For determining how to aggregate the forcing. integer :: j -!$OMP parallel do default(none) shared(G, GV, US, fluxes, optics, nsw, dt_in_T, FluxRescaleDepth, & +!$OMP parallel do default(none) shared(G, GV, US, fluxes, optics, nsw, dt, FluxRescaleDepth, & !$OMP useRiverHeatContent, useCalvingHeatContent, & !$OMP h,T,netMassInOut,netMassOut,Net_heat,Net_salt,Pen_SW_bnd,tv, & !$OMP aggregate_FW) do j=G%jsc, G%jec - call extractFluxes1d(G, GV, US, fluxes, optics, nsw, j, dt_in_T, & + call extractFluxes1d(G, GV, US, fluxes, optics, nsw, j, dt, & FluxRescaleDepth, useRiverHeatContent, useCalvingHeatContent,& h(:,j,:), T(:,j,:), netMassInOut(:,j), netMassOut(:,j), & net_heat(:,j), net_salt(:,j), pen_SW_bnd(:,:,j), tv, aggregate_FW) @@ -2533,12 +2533,12 @@ subroutine forcing_diagnostics(fluxes, sfc_state, G, US, time_end, diag, handles 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(fluxes%seaice_melt_heat)) res(i,j) = res(i,j) + fluxes%seaice_melt_heat(i,j) - if (associated(sfc_state%frazil)) res(i,j) = res(i,j) + US%W_m2_to_QRZ_T*sfc_state%frazil(i,j) * I_dt + 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%seaice_melt_heat)) res(i,j) = res(i,j) + fluxes%seaice_melt_heat(i,j) + if (allocated(sfc_state%frazil)) res(i,j) = res(i,j) + US%W_m2_to_QRZ_T*sfc_state%frazil(i,j) * I_dt !if (associated(sfc_state%TempXpme)) then ! res(i,j) = res(i,j) + sfc_state%TempXpme(i,j) * US%Q_to_J_kg*fluxes%C_p * I_dt !else diff --git a/src/core/MOM_variables.F90 b/src/core/MOM_variables.F90 index 6e0c6974bf..d4d39b516b 100644 --- a/src/core/MOM_variables.F90 +++ b/src/core/MOM_variables.F90 @@ -40,11 +40,13 @@ module MOM_variables SST, & !< The sea surface temperature [degC]. SSS, & !< The sea surface salinity [ppt ~> psu or gSalt/kg]. sfc_density, & !< The mixed layer density [kg m-3]. - Hml, & !< The mixed layer depth [m]. - u, & !< The mixed layer zonal velocity [m s-1]. - v, & !< The mixed layer meridional velocity [m s-1]. - sea_lev, & !< The sea level [m]. If a reduced surface gravity is - !! used, that is compensated for in sea_lev. + Hml, & !< The mixed layer depth [m]. + u, & !< The mixed layer zonal velocity [m s-1]. + v, & !< The mixed layer meridional velocity [m s-1]. + sea_lev, & !< The sea level [m]. If a reduced surface gravity is + !! used, that is compensated for in sea_lev. + frazil, & !< The energy needed to heat the ocean column to the freezing point during + !! the call to step_MOM [J m-2]. melt_potential, & !< Instantaneous amount of heat that can be used to melt sea ice [J m-2]. !! This is computed w.r.t. surface freezing temperature. ocean_mass, & !< The total mass of the ocean [kg m-2]. @@ -62,9 +64,6 @@ module MOM_variables !! conservative temperature in [degC]. logical :: S_is_absS = .false. !< If true, the salinity variable SSS is actually the !! absolute salinity in [g/kg]. - real, pointer, dimension(:,:) :: frazil => NULL() - !< The energy needed to heat the ocean column to the freezing point during the call - !! to step_MOM [J m-2]. type(coupler_2d_bc_type) :: tr_fields !< A structure that may contain an !! array of named fields describing tracer-related quantities. !### NOTE: ALL OF THE ARRAYS IN TR_FIELDS USE THE COUPLER'S INDEXING CONVENTION AND HAVE NO @@ -97,7 +96,7 @@ module MOM_variables real, dimension(:,:), pointer :: frazil => NULL() !< The energy needed to heat the ocean column to the !! freezing point since calculate_surface_state was2 - !! last called [J m-2]. + !! last called [Q Z R ~> J m-2]. real, dimension(:,:), pointer :: salt_deficit => NULL() !< The salt needed to maintain the ocean column !! at a minimum salinity of MIN_SALINITY since the last time @@ -293,7 +292,7 @@ module MOM_variables !> Allocates the fields for the surface (return) properties of !! the ocean model. Unused fields are unallocated. subroutine allocate_surface_state(sfc_state, G, use_temperature, do_integrals, & - gas_fields_ocn, use_meltpot, use_iceshelves) + gas_fields_ocn, use_meltpot, use_iceshelves, omit_frazil) type(ocean_grid_type), intent(in) :: G !< ocean grid structure type(surface), intent(inout) :: sfc_state !< ocean surface state type to be allocated. logical, optional, intent(in) :: use_temperature !< If true, allocate the space for thermodynamic variables. @@ -308,9 +307,11 @@ subroutine allocate_surface_state(sfc_state, G, use_temperature, do_integrals, & logical, optional, intent(in) :: use_meltpot !< If true, allocate the space for melt potential logical, optional, intent(in) :: use_iceshelves !< If true, allocate the space for the stresses !! under ice shelves. + logical, optional, intent(in) :: omit_frazil !< If present and false, do not allocate the space to + !! pass frazil fluxes to the coupler ! local variables - logical :: use_temp, alloc_integ, use_melt_potential, alloc_iceshelves + logical :: use_temp, alloc_integ, use_melt_potential, alloc_iceshelves, alloc_frazil integer :: is, ie, js, je, isd, ied, jsd, jed integer :: isdB, iedB, jsdB, jedB @@ -322,6 +323,7 @@ subroutine allocate_surface_state(sfc_state, G, use_temperature, do_integrals, & alloc_integ = .true. ; if (present(do_integrals)) alloc_integ = do_integrals use_melt_potential = .false. ; if (present(use_meltpot)) use_melt_potential = use_meltpot alloc_iceshelves = .false. ; if (present(use_iceshelves)) alloc_iceshelves = use_iceshelves + alloc_frazil = .true. ; if (present(omit_frazil)) alloc_frazil = .not.omit_frazil if (sfc_state%arrays_allocated) return @@ -331,6 +333,9 @@ subroutine allocate_surface_state(sfc_state, G, use_temperature, do_integrals, & else allocate(sfc_state%sfc_density(isd:ied,jsd:jed)) ; sfc_state%sfc_density(:,:) = 0.0 endif + if (use_temp .and. alloc_frazil) then + allocate(sfc_state%frazil(isd:ied,jsd:jed)) ; sfc_state%frazil(:,:) = 0.0 + endif allocate(sfc_state%sea_lev(isd:ied,jsd:jed)) ; sfc_state%sea_lev(:,:) = 0.0 allocate(sfc_state%Hml(isd:ied,jsd:jed)) ; sfc_state%Hml(:,:) = 0.0 allocate(sfc_state%u(IsdB:IedB,jsd:jed)) ; sfc_state%u(:,:) = 0.0 @@ -461,7 +466,7 @@ subroutine MOM_thermovar_chksum(mesg, tv, G) if (associated(tv%S)) & 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, scale=G%US%Q_to_J_kg*G%US%R_to_kg_m3*G%US%Z_to_m) if (associated(tv%salt_deficit)) & call hchksum(tv%salt_deficit, mesg//" tv%salt_deficit", G%HI, scale=G%US%R_to_kg_m3*G%US%Z_to_m) if (associated(tv%TempxPmE)) & diff --git a/src/diagnostics/MOM_diagnostics.F90 b/src/diagnostics/MOM_diagnostics.F90 index ac7647e66f..d2318ea7b3 100644 --- a/src/diagnostics/MOM_diagnostics.F90 +++ b/src/diagnostics/MOM_diagnostics.F90 @@ -1793,7 +1793,8 @@ subroutine register_surface_diags(Time, G, US, IDs, diag, tv) endif if (associated(tv%frazil)) then IDs%id_fraz = register_diag_field('ocean_model', 'frazil', diag%axesT1, Time, & - 'Heat from frazil formation', 'W m-2', conversion=US%s_to_T, cmor_field_name='hfsifrazil', & + 'Heat from frazil formation', 'W m-2', conversion=US%QRZ_T_to_W_m2, & + cmor_field_name='hfsifrazil', & cmor_standard_name='heat_flux_into_sea_water_due_to_frazil_ice_formation', & cmor_long_name='Heat Flux into Sea Water due to Frazil Ice Formation') endif diff --git a/src/diagnostics/MOM_sum_output.F90 b/src/diagnostics/MOM_sum_output.F90 index 9e4c7af74a..6afc60a6f2 100644 --- a/src/diagnostics/MOM_sum_output.F90 +++ b/src/diagnostics/MOM_sum_output.F90 @@ -1039,7 +1039,7 @@ subroutine accumulate_net_input(fluxes, sfc_state, tv, dt, G, US, CS) enddo ; enddo endif if (associated(tv%frazil)) then ; do j=js,je ; do i=is,ie - heat_in(i,j) = heat_in(i,j) + US%L_to_m**2*G%areaT(i,j) * tv%frazil(i,j) + heat_in(i,j) = heat_in(i,j) + US%L_to_m**2*G%areaT(i,j) * US%Q_to_J_kg*US%R_to_kg_m3*US%Z_to_m*tv%frazil(i,j) enddo ; enddo ; endif if (associated(fluxes%heat_added)) then ; do j=js,je ; do i=is,ie heat_in(i,j) = heat_in(i,j) + RZL2_to_kg*US%Q_to_J_kg * dt*G%areaT(i,j) * fluxes%heat_added(i,j) diff --git a/src/ice_shelf/MOM_marine_ice.F90 b/src/ice_shelf/MOM_marine_ice.F90 index 4042681803..533fb5d9ec 100644 --- a/src/ice_shelf/MOM_marine_ice.F90 +++ b/src/ice_shelf/MOM_marine_ice.F90 @@ -158,11 +158,10 @@ subroutine iceberg_fluxes(G, US, fluxes, use_ice_shelf, sfc_state, & ! form of surface layer evaporation [R Z T-1 ~> kg m-2 s-1]. Update lprec in the ! control structure for diagnostic purposes. - if (associated(sfc_state%frazil)) then + if (allocated(sfc_state%frazil)) then fraz = US%kg_m3_to_R*US%m_to_Z*sfc_state%frazil(i,j) * I_dt_LHF - if (associated(fluxes%evap)) & - fluxes%evap(i,j) = fluxes%evap(i,j) - fraz - ! fluxes%lprec(i,j) = fluxes%lprec(i,j) - fraz + if (associated(fluxes%evap)) fluxes%evap(i,j) = fluxes%evap(i,j) - fraz + ! if (associated(fluxes%lprec)) fluxes%lprec(i,j) = fluxes%lprec(i,j) - fraz sfc_state%frazil(i,j) = 0.0 endif diff --git a/src/parameterizations/vertical/MOM_diabatic_aux.F90 b/src/parameterizations/vertical/MOM_diabatic_aux.F90 index 626b460454..923b2b4899 100644 --- a/src/parameterizations/vertical/MOM_diabatic_aux.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_aux.F90 @@ -99,7 +99,7 @@ module MOM_diabatic_aux !> Frazil formation keeps the temperature above the freezing point. !! This subroutine warms any water that is colder than the (currently !! surface) freezing point up to the freezing point and accumulates -!! the required heat (in J m-2) in tv%frazil. +!! the required heat (in [Q R Z ~> J m-2]) in tv%frazil. subroutine make_frazil(h, tv, G, GV, US, CS, p_surf, halo) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure @@ -116,12 +116,12 @@ subroutine make_frazil(h, tv, G, GV, US, CS, p_surf, halo) ! Local variables real, dimension(SZI_(G)) :: & - fraz_col, & ! The accumulated heat requirement due to frazil [J]. + fraz_col, & ! The accumulated heat requirement due to frazil [Q R Z ~> J m-2]. T_freeze, & ! The freezing potential temperature at the current salinity [degC]. ps ! pressure real, dimension(SZI_(G),SZK_(G)) :: & pressure ! The pressure at the middle of each layer [Pa]. - real :: hc ! A layer's heat capacity [J m-2 degC-1]. + real :: hc ! A layer's heat capacity [Q R Z degC-1 ~> J m-2 degC-1]. logical :: T_fr_set ! True if the freezing point has been calculated for a ! row of points. integer :: i, j, k, is, ie, js, je, nz @@ -169,9 +169,9 @@ subroutine make_frazil(h, tv, G, GV, US, CS, p_surf, halo) if (tv%T(i,j,1) > T_freeze(i)) then ! If frazil had previously been formed, but the surface temperature is now ! above freezing, cool the surface layer with the frazil heat deficit. - hc = (US%Q_to_J_kg*tv%C_p*GV%H_to_kg_m2) * h(i,j,1) + hc = (tv%C_p*GV%H_to_RZ) * h(i,j,1) if (tv%frazil(i,j) - hc * (tv%T(i,j,1) - T_freeze(i)) <= 0.0) then - tv%T(i,j,1) = tv%T(i,j,1) - tv%frazil(i,j)/hc + tv%T(i,j,1) = tv%T(i,j,1) - tv%frazil(i,j) / hc tv%frazil(i,j) = 0.0 else tv%frazil(i,j) = tv%frazil(i,j) - hc * (tv%T(i,j,1) - T_freeze(i)) @@ -192,7 +192,7 @@ subroutine make_frazil(h, tv, G, GV, US, CS, p_surf, halo) T_fr_set = .true. endif - hc = (US%Q_to_J_kg*tv%C_p*GV%H_to_kg_m2) * h(i,j,k) + hc = (tv%C_p*GV%H_to_RZ) * h(i,j,k) if (h(i,j,k) <= 10.0*GV%Angstrom_H) then ! Very thin layers should not be cooled by the frazil flux. if (tv%T(i,j,k) < T_freeze(i)) then @@ -201,7 +201,7 @@ subroutine make_frazil(h, tv, G, GV, US, CS, p_surf, halo) endif else if (fraz_col(i) + hc * (T_freeze(i) - tv%T(i,j,k)) <= 0.0) then - tv%T(i,j,k) = tv%T(i,j,k) - fraz_col(i)/hc + tv%T(i,j,k) = tv%T(i,j,k) - fraz_col(i) / hc fraz_col(i) = 0.0 else fraz_col(i) = fraz_col(i) + hc * (T_freeze(i) - tv%T(i,j,k)) From 7102ceac6c38562c07d15d61f8f3848aedf95bba Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 21 Feb 2020 22:32:18 -0500 Subject: [PATCH 075/316] +Rescaled some latent heat constants Rescaled the latent heats of vaporization and fusion to [ Q ] and constantHeatForcing to [Q R Z T-1]. Also simplified the use of duplicative variables in MOM_forcing_type, fixed comments, and rescaled 4 heat flux diagnostics. All answers are bitwise identical. --- .../solo_driver/MOM_surface_forcing.F90 | 39 +++++++++-------- src/core/MOM.F90 | 6 +-- src/core/MOM_forcing_type.F90 | 42 ++++++++----------- src/core/MOM_variables.F90 | 2 +- src/diagnostics/MOM_diagnostics.F90 | 22 +++++----- src/ice_shelf/MOM_ice_shelf.F90 | 2 +- .../vertical/MOM_diabatic_driver.F90 | 14 ++++--- 7 files changed, 62 insertions(+), 65 deletions(-) diff --git a/config_src/solo_driver/MOM_surface_forcing.F90 b/config_src/solo_driver/MOM_surface_forcing.F90 index c5a924913d..f516a1480a 100644 --- a/config_src/solo_driver/MOM_surface_forcing.F90 +++ b/config_src/solo_driver/MOM_surface_forcing.F90 @@ -83,8 +83,8 @@ module MOM_surface_forcing real :: Flux_const !< piston velocity for surface restoring [Z T-1 ~> m s-1] real :: Flux_const_T !< piston velocity for surface temperature restoring [m s-1] real :: Flux_const_S !< piston velocity for surface salinity restoring [Z T-1 ~> m s-1] - real :: latent_heat_fusion !< latent heat of fusion times scaling factors [J T m-2 R-1 Z-1 s-1 ~> J kg-1] - real :: latent_heat_vapor !< latent heat of vaporization [J kg-1] + real :: latent_heat_fusion !< latent heat of fusion times [Q ~> J kg-1] + real :: latent_heat_vapor !< latent heat of vaporization [Q ~> J kg-1] real :: tau_x0 !< Constant zonal wind stress used in the WIND_CONFIG="const" forcing real :: tau_y0 !< Constant meridional wind stress used in the WIND_CONFIG="const" forcing @@ -121,7 +121,7 @@ module MOM_surface_forcing logical :: dataOverrideIsInitialized = .false. !< If true, data override has been initialized real :: wind_scale !< value by which wind-stresses are scaled, ND. - real :: constantHeatForcing !< value used for sensible heat flux when buoy_config="const" + real :: constantHeatForcing !< value used for sensible heat flux when buoy_config="const" [Q R Z T-1 ~> W m-2] character(len=8) :: wind_stagger !< A character indicating how the wind stress components !! are staggered in WIND_FILE. Valid values are A or C for now. @@ -836,11 +836,10 @@ subroutine buoyancy_forcing_from_files(sfc_state, fluxes, day, dt, G, US, CS) case default ; time_lev = 1 end select if (CS%archaic_OMIP_file) then - call MOM_read_data(CS%evaporation_file, CS%evap_var, temp(:,:), & - G%Domain, timelevel=time_lev) + call MOM_read_data(CS%evaporation_file, CS%evap_var, fluxes%evap(:,:), & + G%Domain, timelevel=time_lev, scale=-kg_m2_s_conversion) do j=js,je ; do i=is,ie - fluxes%latent(i,j) = -US%W_m2_to_QRZ_T*CS%latent_heat_vapor*temp(i,j) - fluxes%evap(i,j) = -kg_m2_s_conversion*temp(i,j) + fluxes%latent(i,j) = CS%latent_heat_vapor*fluxes%evap(i,j) fluxes%latent_evap_diag(i,j) = fluxes%latent(i,j) enddo ; enddo else @@ -973,8 +972,8 @@ subroutine buoyancy_forcing_from_files(sfc_state, fluxes, day, dt, G, US, CS) fluxes%latent(i,j) = fluxes%latent(i,j) * G%mask2dT(i,j) fluxes%latent_evap_diag(i,j) = fluxes%latent_evap_diag(i,j) * G%mask2dT(i,j) - fluxes%latent_fprec_diag(i,j) = -fluxes%fprec(i,j)*US%W_m2_to_QRZ_T*CS%latent_heat_fusion - fluxes%latent_frunoff_diag(i,j) = -fluxes%frunoff(i,j)*US%W_m2_to_QRZ_T*CS%latent_heat_fusion + fluxes%latent_fprec_diag(i,j) = -fluxes%fprec(i,j)*CS%latent_heat_fusion + fluxes%latent_frunoff_diag(i,j) = -fluxes%frunoff(i,j)*CS%latent_heat_fusion enddo ; enddo endif ! time_lev /= CS%buoy_last_lev_read @@ -1090,12 +1089,12 @@ subroutine buoyancy_forcing_from_data_override(sfc_state, fluxes, day, dt, G, US ! note the sign convention do j=js,je ; do i=is,ie - ! This is dangerous because it is not clear whether the data files have been read! - fluxes%evap(i,j) = -fluxes%evap(i,j) ! Normal convention is positive into the ocean - ! but evap is normally a positive quantity in the files - fluxes%latent(i,j) = US%W_m2_to_QRZ_T * CS%latent_heat_vapor*fluxes%evap(i,j) + ! The normal convention is that fluxes%evap positive into the ocean + ! but evap is normally a positive quantity in the files + ! This conversion is dangerous because it is not clear whether the data files have been read! + fluxes%evap(i,j) = -kg_m2_s_conversion*fluxes%evap(i,j) + fluxes%latent(i,j) = CS%latent_heat_vapor*fluxes%evap(i,j) fluxes%latent_evap_diag(i,j) = fluxes%latent(i,j) - fluxes%evap(i,j) = kg_m2_s_conversion*fluxes%evap(i,j) enddo ; enddo call data_override('OCN', 'sens', fluxes%sens(:,:), day, & @@ -1193,8 +1192,8 @@ subroutine buoyancy_forcing_from_data_override(sfc_state, fluxes, day, dt, G, US fluxes%sw(i,j) = fluxes%sw(i,j) * G%mask2dT(i,j) fluxes%latent_evap_diag(i,j) = fluxes%latent_evap_diag(i,j) * G%mask2dT(i,j) - fluxes%latent_fprec_diag(i,j) = -fluxes%fprec(i,j)*US%W_m2_to_QRZ_T*CS%latent_heat_fusion - fluxes%latent_frunoff_diag(i,j) = -fluxes%frunoff(i,j)*US%W_m2_to_QRZ_T*CS%latent_heat_fusion + fluxes%latent_fprec_diag(i,j) = -fluxes%fprec(i,j)*CS%latent_heat_fusion + fluxes%latent_frunoff_diag(i,j) = -fluxes%frunoff(i,j)*CS%latent_heat_fusion enddo ; enddo @@ -1281,7 +1280,7 @@ subroutine buoyancy_forcing_const(sfc_state, fluxes, day, dt, G, US, CS) fluxes%frunoff(i,j) = 0.0 fluxes%lw(i,j) = 0.0 fluxes%latent(i,j) = 0.0 - fluxes%sens(i,j) = US%W_m2_to_QRZ_T * CS%constantHeatForcing * G%mask2dT(i,j) + fluxes%sens(i,j) = CS%constantHeatForcing * G%mask2dT(i,j) fluxes%sw(i,j) = 0.0 fluxes%latent_evap_diag(i,j) = 0.0 fluxes%latent_fprec_diag(i,j) = 0.0 @@ -1595,7 +1594,7 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, tracer_flow_C call get_param(param_file, mdl, "SENSIBLE_HEAT_FLUX", CS%constantHeatForcing, & "A constant heat forcing (positive into ocean) applied "//& "through the sensible heat flux field. ", & - units='W/m2', fail_if_missing=.true.) + units='W/m2', scale=US%W_m2_to_QRZ_T, fail_if_missing=.true.) endif call get_param(param_file, mdl, "WIND_CONFIG", CS%wind_config, & "The character string that indicates how wind forcing "//& @@ -1675,9 +1674,9 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, tracer_flow_C "given by FLUXCONST.", default= .false.) call get_param(param_file, mdl, "LATENT_HEAT_FUSION", CS%latent_heat_fusion, & "The latent heat of fusion.", default=hlf, & - units="J/kg", scale=US%R_to_kg_m3*US%Z_to_m*US%s_to_T) + units="J/kg", scale=US%J_kg_to_Q) call get_param(param_file, mdl, "LATENT_HEAT_VAPORIZATION", CS%latent_heat_vapor, & - "The latent heat of fusion.", units="J/kg", default=hlv) + "The latent heat of fusion.", default=hlv, units="J/kg", scale=US%J_kg_to_Q) if (CS%restorebuoy) then ! These three variables use non-standard time units, but are rescaled as they are read. call get_param(param_file, mdl, "FLUXCONST", CS%Flux_const, & diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index 0557d6042c..3c85df46f0 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -2745,7 +2745,7 @@ subroutine extract_surface_state(CS, sfc_state) real :: H_rescale !< A conversion factor from thickness units to the units used in the !! calculation of properties of the uppermost ocean [nondim] or [Z H-1 ~> 1 or m3 kg-1] ! After the ANSWERS_2018 flag has been obsoleted, H_rescale will be 1. - real :: delT(SZI_(CS%G)) !< T-T_freeze [degC] + real :: delT(SZI_(CS%G)) !< Depth integral of T-T_freeze [m degC] logical :: use_temperature !< If true, temp and saln used as state variables. integer :: i, j, k, is, ie, js, je, nz, numberOfErrors, ig, jg integer :: isd, ied, jsd, jed @@ -2941,7 +2941,7 @@ subroutine extract_surface_state(CS, sfc_state) enddo do k=1,nz ; do i=is,ie - depth_ml = min(CS%HFrz,CS%visc%MLD(i,j)) + depth_ml = min(CS%HFrz, CS%visc%MLD(i,j)) if (depth(i) + h(i,j,k)*GV%H_to_m < depth_ml) then dh = h(i,j,k)*GV%H_to_m elseif (depth(i) < depth_ml) then @@ -2962,7 +2962,7 @@ subroutine extract_surface_state(CS, sfc_state) if (G%mask2dT(i,j)>0.) then ! instantaneous melt_potential [J m-2] - sfc_state%melt_potential(i,j) = US%Q_to_J_kg*CS%tv%C_p * US%R_to_kg_m3*GV%Rho0 * delT(i) + sfc_state%melt_potential(i,j) = US%Q_to_J_kg*US%R_to_kg_m3 * CS%tv%C_p * GV%Rho0 * delT(i) endif enddo enddo ! end of j loop diff --git a/src/core/MOM_forcing_type.F90 b/src/core/MOM_forcing_type.F90 index 463d825fa3..d836f86974 100644 --- a/src/core/MOM_forcing_type.F90 +++ b/src/core/MOM_forcing_type.F90 @@ -414,11 +414,8 @@ subroutine extractFluxes1d(G, GV, US, fluxes, optics, nsw, j, dt, & real :: Ih_limit ! inverse depth at which surface fluxes start to be limited ! or 0 for no limiting [H-1 ~> m-1 or m2 kg-1] real :: scale ! scale scales away fluxes if depth < FluxRescaleDepth - real :: QRZ_to_H ! Converts heat in Q R Z to H degC [degC H Q-1 R-1 Z-1 ~> degC m3 J-1 or degC kg J-1] - real :: RZ_T_to_W_m2_degC ! Converts mass fluxes to heat fluxes per degree temperature - ! change [W m-2 degC-1 T R-1 Z-1 ~> J kg degC] real :: I_Cp ! 1.0 / C_p [degC Q-1 ~> kg degC J-1] - real :: RZcp_to_H ! Unit convsersion factors divided by the heat capacity + real :: I_Cp_Hconvert ! Unit conversion factors divided by the heat capacity ! [degC H R-1 Z-1 Q-1 ~> degC m3 J-1 or kg degC J-1] logical :: calculate_diags ! Indicate to calculate/update diagnostic arrays character(len=200) :: mesg @@ -441,11 +438,8 @@ subroutine extractFluxes1d(G, GV, US, fluxes, optics, nsw, j, dt, & !}BGR Ih_limit = 0.0 ; if (FluxRescaleDepth > 0.0) Ih_limit = 1.0 / FluxRescaleDepth - ! RZ_T_to_W_m2_degC = US%Q_to_J_kg*fluxes%C_p*US%R_to_kg_m3*US%Z_to_m*US%s_to_T - RZ_T_to_W_m2_degC = US%QRZ_T_to_W_m2*fluxes%C_p I_Cp = 1.0 / fluxes%C_p - QRZ_to_H = US%R_to_kg_m3 * US%Z_to_m * (1.0 / (GV%H_to_kg_m2 * fluxes%C_p)) - RZcP_to_H = 1.0 / (GV%H_to_RZ * fluxes%C_p) + I_Cp_Hconvert = 1.0 / (GV%H_to_RZ * fluxes%C_p) is = G%isc ; ie = G%iec ; nz = G%ke @@ -497,7 +491,7 @@ subroutine extractFluxes1d(G, GV, US, fluxes, optics, nsw, j, dt, & Pen_sw_tot(i) = 0.0 if (nsw >= 1) then do n=1,nsw - Pen_SW_bnd(n,i) = RZcP_to_H*scale*dt * max(0.0, Pen_SW_bnd(n,i)) + Pen_SW_bnd(n,i) = I_Cp_Hconvert*scale*dt * max(0.0, Pen_SW_bnd(n,i)) Pen_sw_tot(i) = Pen_sw_tot(i) + Pen_SW_bnd(n,i) enddo else @@ -508,7 +502,7 @@ subroutine extractFluxes1d(G, GV, US, fluxes, optics, nsw, j, dt, & pen_sw_tot_rate(i) = 0.0 if (nsw >= 1) then do n=1,nsw - Pen_SW_bnd_rate(n,i) = RZcP_to_H*scale * max(0.0, Pen_SW_bnd_rate(n,i)) + Pen_SW_bnd_rate(n,i) = I_Cp_Hconvert*scale * max(0.0, Pen_SW_bnd_rate(n,i)) pen_sw_tot_rate(i) = pen_sw_tot_rate(i) + pen_sw_bnd_rate(n,i) enddo else @@ -581,36 +575,36 @@ subroutine extractFluxes1d(G, GV, US, fluxes, optics, nsw, j, dt, & ! CIME provides heat flux from snow&ice melt (seaice_melt_heat), so this is added below if (associated(fluxes%seaice_melt_heat)) then - net_heat(i) = scale * dt * RZcP_to_H * & + net_heat(i) = scale * dt * I_Cp_Hconvert * & ( fluxes%sw(i,j) + (((fluxes%lw(i,j) + fluxes%latent(i,j)) + fluxes%sens(i,j)) + & fluxes%seaice_melt_heat(i,j)) ) !Repeats above code w/ dt=1. for legacy reason - if (do_NHR) net_heat_rate(i) = scale * RZcP_to_H * & + if (do_NHR) net_heat_rate(i) = scale * I_Cp_Hconvert * & ( fluxes%sw(i,j) + (((fluxes%lw(i,j) + fluxes%latent(i,j)) + fluxes%sens(i,j)) + & fluxes%seaice_melt_heat(i,j))) else - net_heat(i) = scale * dt * RZcP_to_H * & + net_heat(i) = scale * dt * I_Cp_Hconvert * & ( fluxes%sw(i,j) + ((fluxes%lw(i,j) + fluxes%latent(i,j)) + fluxes%sens(i,j)) ) !Repeats above code w/ dt=1. for legacy reason - if (do_NHR) net_heat_rate(i) = scale * RZcP_to_H * & + if (do_NHR) net_heat_rate(i) = scale * I_Cp_Hconvert * & ( fluxes%sw(i,j) + ((fluxes%lw(i,j) + fluxes%latent(i,j)) + fluxes%sens(i,j)) ) endif ! Add heat flux from surface damping (restoring) (K * H) or flux adjustments. if (associated(fluxes%heat_added)) then - net_heat(i) = net_heat(i) + (scale * (dt * QRZ_to_H)) * fluxes%heat_added(i,j) - if (do_NHR) net_heat_rate(i) = net_heat_rate(i) + (scale * QRZ_to_H) * fluxes%heat_added(i,j) + net_heat(i) = net_heat(i) + (scale * (dt * I_Cp_Hconvert)) * fluxes%heat_added(i,j) + if (do_NHR) net_heat_rate(i) = net_heat_rate(i) + (scale * I_Cp_Hconvert) * fluxes%heat_added(i,j) endif ! Add explicit heat flux for runoff (which is part of the ice-ocean boundary ! flux type). Runoff is otherwise added with a temperature of SST. if (useRiverHeatContent) then ! remove lrunoff*SST here, to counteract its addition elsewhere - net_heat(i) = (net_heat(i) + (scale*(dt * RZcP_to_H)) * fluxes%heat_content_lrunoff(i,j)) - & + net_heat(i) = (net_heat(i) + (scale*(dt * I_Cp_Hconvert)) * fluxes%heat_content_lrunoff(i,j)) - & (GV%RZ_to_H * (scale * dt)) * fluxes%lrunoff(i,j) * T(i,1) !BGR-Jul 5, 2017{ !Intentionally neglect the following contribution to rate for legacy reasons. - !if (do_NHR) net_heat_rate(i) = (net_heat_rate(i) + (scale*RZcP_to_H) * fluxes%heat_content_lrunoff(i,j)) - & + !if (do_NHR) net_heat_rate(i) = (net_heat_rate(i) + (scale*I_Cp_Hconvert) * fluxes%heat_content_lrunoff(i,j)) - & ! (GV%RZ_to_H * (scale)) * fluxes%lrunoff(i,j) * T(i,1) !}BGR if (calculate_diags .and. associated(tv%TempxPmE)) then @@ -623,11 +617,11 @@ subroutine extractFluxes1d(G, GV, US, fluxes, optics, nsw, j, dt, & ! flux type). Calving is otherwise added with a temperature of SST. if (useCalvingHeatContent) then ! remove frunoff*SST here, to counteract its addition elsewhere - net_heat(i) = net_heat(i) + (scale*(dt * RZcP_to_H)) * fluxes%heat_content_frunoff(i,j) - & + net_heat(i) = net_heat(i) + (scale*(dt * I_Cp_Hconvert)) * fluxes%heat_content_frunoff(i,j) - & (GV%RZ_to_H * (scale * dt)) * fluxes%frunoff(i,j) * T(i,1) !BGR-Jul 5, 2017{ !Intentionally neglect the following contribution to rate for legacy reasons. -! if (do_NHR) net_heat_rate(i) = net_heat_rate(i) + (scale*RZcP_to_H) * fluxes%heat_content_frunoff(i,j) - & +! if (do_NHR) net_heat_rate(i) = net_heat_rate(i) + (scale*I_Cp_Hconvert) * fluxes%heat_content_frunoff(i,j) - & ! (GV%RZ_to_H * scale) * fluxes%frunoff(i,j) * T(i,1) !}BGR if (calculate_diags .and. associated(tv%TempxPmE)) then @@ -646,19 +640,19 @@ subroutine extractFluxes1d(G, GV, US, fluxes, optics, nsw, j, dt, & ! 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 -! net_heat(i) = net_heat(i) + scale * dt * RZcP_to_H * & +! net_heat(i) = net_heat(i) + scale * dt * I_Cp_Hconvert * & ! (fluxes%heat_content_lprec(i,j) + (fluxes%heat_content_fprec(i,j) + & ! (fluxes%heat_content_lrunoff(i,j) + (fluxes%heat_content_frunoff(i,j) + & ! (fluxes%heat_content_cond(i,j) + fluxes%heat_content_vprec(i,j)))))) ! endif if (fluxes%num_msg < fluxes%max_msg) then - if (Pen_SW_tot(i) > 1.000001 * RZcP_to_H*scale*dt*fluxes%sw(i,j)) then + if (Pen_SW_tot(i) > 1.000001 * I_Cp_Hconvert*scale*dt*fluxes%sw(i,j)) then fluxes%num_msg = fluxes%num_msg + 1 write(mesg,'("Penetrating shortwave of ",1pe17.10, & &" exceeds total shortwave of ",1pe17.10,& &" at ",1pg11.4,"E, "1pg11.4,"N.")') & - Pen_SW_tot(i), RZcP_to_H*scale*dt * fluxes%sw(i,j), & + Pen_SW_tot(i), I_Cp_Hconvert*scale*dt * fluxes%sw(i,j), & G%geoLonT(i,j),G%geoLatT(i,j) call MOM_error(WARNING,mesg) endif @@ -672,7 +666,7 @@ subroutine extractFluxes1d(G, GV, US, fluxes, optics, nsw, j, dt, & ! diagnose non-downwelling SW if (present(nonPenSW)) then - nonPenSW(i) = scale * dt * RZcP_to_H * fluxes%sw(i,j) - Pen_SW_tot(i) + nonPenSW(i) = scale * dt * I_Cp_Hconvert * fluxes%sw(i,j) - Pen_SW_tot(i) endif ! Salt fluxes diff --git a/src/core/MOM_variables.F90 b/src/core/MOM_variables.F90 index d4d39b516b..ccf2fd3784 100644 --- a/src/core/MOM_variables.F90 +++ b/src/core/MOM_variables.F90 @@ -224,7 +224,7 @@ module MOM_variables real, pointer, dimension(:,:) :: nkml_visc_v => NULL() !< The number of layers in the viscous surface mixed layer at v-points [nondim]. real, pointer, dimension(:,:) :: & - MLD => NULL() !< Instantaneous active mixing layer depth [H ~> m or kg m-2]. + MLD => NULL() !< Instantaneous active mixing layer depth in unscaled MKS units [m]. real, pointer, dimension(:,:,:) :: & Ray_u => NULL(), & !< The Rayleigh drag velocity to be applied to each layer at u-points [Z T-1 ~> m s-1]. Ray_v => NULL() !< The Rayleigh drag velocity to be applied to each layer at v-points [Z T-1 ~> m s-1]. diff --git a/src/diagnostics/MOM_diagnostics.F90 b/src/diagnostics/MOM_diagnostics.F90 index d2318ea7b3..37efe52b1f 100644 --- a/src/diagnostics/MOM_diagnostics.F90 +++ b/src/diagnostics/MOM_diagnostics.F90 @@ -1272,7 +1272,7 @@ subroutine post_surface_thermo_diags(IDs, G, GV, US, diag, dt_int, sfc_state, tv ! post temperature of P-E+R 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) * (US%Q_to_J_kg*tv%C_p * I_time_int) + work_2d(i,j) = tv%TempxPmE(i,j) * (tv%C_p * I_time_int) enddo ; enddo call post_data(IDs%id_Heat_PmE, work_2d, diag, mask=G%mask2dT) endif @@ -1280,7 +1280,7 @@ subroutine post_surface_thermo_diags(IDs, G, GV, US, diag, dt_int, sfc_state, tv ! post geothermal heating or internal heat source/sinks 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) * (US%Q_to_J_kg*tv%C_p * I_time_int) + work_2d(i,j) = tv%internal_heat(i,j) * (tv%C_p * I_time_int) enddo ; enddo call post_data(IDs%id_intern_heat, work_2d, diag, mask=G%mask2dT) endif @@ -1802,12 +1802,13 @@ subroutine register_surface_diags(Time, G, US, IDs, diag, tv) IDs%id_salt_deficit = register_diag_field('ocean_model', 'salt_deficit', diag%axesT1, Time, & 'Salt sink in ocean due to ice flux', & - 'psu m-2 s-1', conversion=G%US%R_to_kg_m3*G%US%Z_to_m*US%s_to_T) + 'psu m-2 s-1', conversion=US%R_to_kg_m3*US%Z_to_m*US%s_to_T) IDs%id_Heat_PmE = register_diag_field('ocean_model', 'Heat_PmE', diag%axesT1, Time, & 'Heat flux into ocean from mass flux into ocean', & - 'W m-2', conversion=G%US%R_to_kg_m3*G%US%Z_to_m*US%s_to_T) + 'W m-2', conversion=US%QRZ_T_to_W_m2) IDs%id_intern_heat = register_diag_field('ocean_model', 'internal_heat', diag%axesT1, Time,& - 'Heat flux into ocean from geothermal or other internal sources', 'W m-2', conversion=US%s_to_T) + 'Heat flux into ocean from geothermal or other internal sources', 'W m-2', & + conversion=US%Q_to_J_kg*US%s_to_T) end subroutine register_surface_diags @@ -2023,11 +2024,12 @@ subroutine write_static_fields(G, GV, US, tv, diag) use_temperature = associated(tv%T) if (use_temperature) then - id = register_static_field('ocean_model','C_p', diag%axesNull, & - 'heat capacity of sea water', 'J kg-1 K-1', cmor_field_name='cpocean', & - cmor_standard_name='specific_heat_capacity_of_sea_water', & - cmor_long_name='specific_heat_capacity_of_sea_water') - if (id > 0) call post_data(id, US%Q_to_J_kg*tv%C_p, diag, .true.) + id = register_static_field('ocean_model','C_p', diag%axesNull, & + 'heat capacity of sea water', 'J kg-1 K-1', conversion=US%Q_to_J_kg, & + cmor_field_name='cpocean', & + cmor_standard_name='specific_heat_capacity_of_sea_water', & + cmor_long_name='specific_heat_capacity_of_sea_water') + if (id > 0) call post_data(id, tv%C_p, diag, .true.) endif end subroutine write_static_fields diff --git a/src/ice_shelf/MOM_ice_shelf.F90 b/src/ice_shelf/MOM_ice_shelf.F90 index e5a29245bc..50282a319b 100644 --- a/src/ice_shelf/MOM_ice_shelf.F90 +++ b/src/ice_shelf/MOM_ice_shelf.F90 @@ -1059,9 +1059,9 @@ subroutine add_shelf_flux(G, US, CS, state, fluxes) ! 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) = US%W_m2_to_QRZ_T*fluxes%vprec(i,j) * CS%Cp * CS%T0 ! W /m^2 ! Rescale fluxes%vprec to the proper units. fluxes%vprec(i,j) = US%kg_m3_to_R*US%m_to_Z*US%T_to_s * fluxes%vprec(i,j) + fluxes%sens(i,j) = fluxes%vprec(i,j) * US%J_kg_to_Q*CS%Cp * CS%T0 ! [ Q R Z T-1 ~> 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 diff --git a/src/parameterizations/vertical/MOM_diabatic_driver.F90 b/src/parameterizations/vertical/MOM_diabatic_driver.F90 index a19402eded..2505c5677c 100644 --- a/src/parameterizations/vertical/MOM_diabatic_driver.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_driver.F90 @@ -2945,7 +2945,7 @@ subroutine diagnose_diabatic_diff_tendency(tv, h, temp_old, saln_old, dt, G, GV, ! heat tendency 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 * US%Q_to_J_kg*tv%C_p * work_3d(i,j,k) + work_3d(i,j,k) = h(i,j,k) * tv%C_p * work_3d(i,j,k) enddo ; enddo ; enddo 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) @@ -3128,7 +3128,7 @@ subroutine diagnose_frazil_tendency(tv, h, temp_old, dt, G, GV, US, CS) ! heat tendency if (CS%id_frazil_heat_tend > 0 .or. CS%id_frazil_heat_tend_2d > 0) then do k=1,nz ; do j=js,je ; do i=is,ie - CS%frazil_heat_diag(i,j,k) = GV%H_to_kg_m2 * US%Q_to_J_kg*tv%C_p * h(i,j,k) * Idt * (tv%T(i,j,k)-temp_old(i,j,k)) + CS%frazil_heat_diag(i,j,k) = tv%C_p * h(i,j,k) * Idt * (tv%T(i,j,k)-temp_old(i,j,k)) enddo ; enddo ; enddo if (CS%id_frazil_heat_tend > 0) call post_data(CS%id_frazil_heat_tend, CS%frazil_heat_diag(:,:,:), CS%diag) @@ -3538,7 +3538,7 @@ subroutine diabatic_driver_init(Time, G, GV, US, param_file, useALEalgorithm, di CS%id_diabatic_diff_heat_tend = register_diag_field('ocean_model', & 'diabatic_heat_tendency', diag%axesTL, Time, & 'Diabatic diffusion heat tendency', & - 'W m-2', conversion=US%s_to_T, cmor_field_name='opottempdiff', & + 'W m-2', conversion=GV%H_to_RZ*US%QRZ_T_to_W_m2, 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 '// & @@ -3565,7 +3565,7 @@ subroutine diabatic_driver_init(Time, G, GV, US, param_file, useALEalgorithm, di 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', conversion=US%s_to_T, cmor_field_name='opottempdiff_2d', & + 'W m-2', conversion=GV%H_to_RZ*US%QRZ_T_to_W_m2, 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 '//& @@ -3664,7 +3664,8 @@ subroutine diabatic_driver_init(Time, G, GV, US, param_file, useALEalgorithm, di ! diagnostic for tendency of heat due to frazil CS%id_frazil_heat_tend = register_diag_field('ocean_model',& 'frazil_heat_tendency', diag%axesTL, Time, & - 'Heat tendency due to frazil formation', 'W m-2', conversion=US%s_to_T, v_extensive=.true.) + 'Heat tendency due to frazil formation', & + 'W m-2', conversion=GV%H_to_RZ*US%QRZ_T_to_W_m2, v_extensive=.true.) if (CS%id_frazil_heat_tend > 0) then CS%frazil_tendency_diag = .true. endif @@ -3672,7 +3673,8 @@ subroutine diabatic_driver_init(Time, G, GV, US, param_file, useALEalgorithm, di ! if all is working propertly, this diagnostic should equal to hfsifrazil CS%id_frazil_heat_tend_2d = register_diag_field('ocean_model',& 'frazil_heat_tendency_2d', diag%axesT1, Time, & - 'Depth integrated heat tendency due to frazil formation', 'W m-2', conversion=US%s_to_T) + 'Depth integrated heat tendency due to frazil formation', & + 'W m-2', conversion=GV%H_to_RZ*US%QRZ_T_to_W_m2) if (CS%id_frazil_heat_tend_2d > 0) then CS%frazil_tendency_diag = .true. endif From 84cdd5e8a2c6c1e99e7cc662ea3bd760d3e16904 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 21 Feb 2020 23:20:14 -0500 Subject: [PATCH 076/316] +Rescaled units of geothermal heat fluxes Rescaled the units of the geothermal heat fluxes to [Q R Z T-1] for dimensional consistency testing. All answers are bitwise identical. --- .../vertical/MOM_geothermal.F90 | 25 +++++++++---------- 1 file changed, 12 insertions(+), 13 deletions(-) diff --git a/src/parameterizations/vertical/MOM_geothermal.F90 b/src/parameterizations/vertical/MOM_geothermal.F90 index a0f19a46ab..b59b45431d 100644 --- a/src/parameterizations/vertical/MOM_geothermal.F90 +++ b/src/parameterizations/vertical/MOM_geothermal.F90 @@ -104,7 +104,7 @@ subroutine geothermal(h, tv, dt, ea, eb, G, GV, US, CS, halo) real :: I_h ! inverse thickness [H-1 ~> m-1 or m2 kg-1] real :: dTemp ! temperature increase in a layer [degC] real :: Irho_cp ! inverse of heat capacity per unit layer volume - ! [degC H m2 J-1 ~> degC m3 J-1 or degC kg J-1] + ! [degC H Q-1 R-1 Z-1 ~> degC m3 J-1 or degC kg J-1] real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: T_old ! Temperature of each layer ! before any heat is added, @@ -132,7 +132,7 @@ subroutine geothermal(h, tv, dt, ea, eb, G, GV, US, CS, halo) if (.not.CS%apply_geothermal) return nkmb = GV%nk_rho_varies - Irho_cp = 1.0 / (GV%H_to_kg_m2 * US%Q_to_J_kg*tv%C_p) + Irho_cp = 1.0 / (GV%H_to_RZ * tv%C_p) Angstrom = GV%Angstrom_H H_neglect = GV%H_subroundoff p_ref(:) = tv%P_Ref @@ -337,8 +337,7 @@ subroutine geothermal(h, tv, dt, ea, eb, G, GV, US, CS, halo) ! Calculate heat tendency due to addition and transfer of internal heat if (CS%id_internal_heat_heat_tendency > 0) then - work_3d(i,j,k) = ((GV%H_to_kg_m2 * US%Q_to_J_kg*tv%C_p) * Idt) * & - (h(i,j,k) * tv%T(i,j,k) - h_old(i,j,k) * T_old(i,j,k)) + work_3d(i,j,k) = (tv%C_p * Idt) * (h(i,j,k) * tv%T(i,j,k) - h_old(i,j,k) * T_old(i,j,k)) endif endif ; enddo @@ -392,8 +391,8 @@ subroutine geothermal_init(Time, G, GV, US, param_file, diag, CS) character(len=48) :: thickness_units ! Local variables character(len=200) :: inputdir, geo_file, filename, geotherm_var - real :: scale ! A constant heat flux or dimensionally rescaled scaling factor - ! [J m-2 T-1 ~> W m-2] or [s T-1 ~> 1] + real :: geo_scale ! A constant heat flux or dimensionally rescaled geothermal flux scaling factor + ! [Q R Z T-1 ~> W m-2] or [Q R Z m2 s J-1 T-1 ~> 1] integer :: i, j, isd, ied, jsd, jed, id isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed @@ -408,12 +407,12 @@ subroutine geothermal_init(Time, G, GV, US, param_file, diag, CS) ! write parameters to the model log. call log_version(param_file, mdl, version, "") - call get_param(param_file, mdl, "GEOTHERMAL_SCALE", scale, & + call get_param(param_file, mdl, "GEOTHERMAL_SCALE", geo_scale, & "The constant geothermal heat flux, a rescaling "//& "factor for the heat flux read from GEOTHERMAL_FILE, or "//& "0 to disable the geothermal heating.", & - units="W m-2 or various", default=0.0, scale=US%T_to_s) - CS%apply_geothermal = .not.(scale == 0.0) + units="W m-2 or various", default=0.0, scale=US%W_m2_to_QRZ_T) + CS%apply_geothermal = .not.(geo_scale == 0.0) if (.not.CS%apply_geothermal) return call safe_alloc_ptr(CS%geo_heat, isd, ied, jsd, jed) ; CS%geo_heat(:,:) = 0.0 @@ -442,11 +441,11 @@ subroutine geothermal_init(Time, G, GV, US, param_file, diag, CS) "GEOTHERMAL_FILE.", default="geo_heat") call MOM_read_data(filename, trim(geotherm_var), CS%geo_heat, G%Domain) do j=jsd,jed ; do i=isd,ied - CS%geo_heat(i,j) = (G%mask2dT(i,j) * scale) * CS%geo_heat(i,j) + CS%geo_heat(i,j) = (G%mask2dT(i,j) * geo_scale) * CS%geo_heat(i,j) enddo ; enddo else do j=jsd,jed ; do i=isd,ied - CS%geo_heat(i,j) = G%mask2dT(i,j) * scale + CS%geo_heat(i,j) = G%mask2dT(i,j) * geo_scale enddo ; enddo endif call pass_var(CS%geo_heat, G%domain) @@ -455,7 +454,7 @@ subroutine geothermal_init(Time, G, GV, US, param_file, diag, CS) ! post the static geothermal heating field id = register_static_field('ocean_model', 'geo_heat', diag%axesT1, & - 'Geothermal heat flux into ocean', 'W m-2', conversion=US%s_to_T, & + 'Geothermal heat flux into ocean', 'W m-2', conversion=US%QRZ_T_to_W_m2, & cmor_field_name='hfgeou', cmor_units='W m-2', & cmor_standard_name='upward_geothermal_heat_flux_at_sea_floor', & cmor_long_name='Upward geothermal heat flux at sea floor', & @@ -466,7 +465,7 @@ subroutine geothermal_init(Time, G, GV, US, param_file, diag, CS) CS%id_internal_heat_heat_tendency=register_diag_field('ocean_model', & 'internal_heat_heat_tendency', diag%axesTL, Time, & 'Heat tendency (in 3D) due to internal (geothermal) sources', & - 'W m-2', conversion=US%s_to_T, v_extensive=.true.) + 'W m-2', conversion=GV%H_to_RZ*US%QRZ_T_to_W_m2, v_extensive=.true.) CS%id_internal_heat_temp_tendency=register_diag_field('ocean_model', & 'internal_heat_temp_tendency', diag%axesTL, Time, & 'Temperature tendency (in 3D) due to internal (geothermal) sources', & From 71b853095f6803ed6cf6e751c4337eea4010e9e0 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sat, 22 Feb 2020 07:26:15 -0500 Subject: [PATCH 077/316] +Rescaled the units of tv%internal_heat Rescaled the units of tv%internal_heat fluxes to [degC R Z] for dimensional consistency testing. The internal calculation of the boundary forcing heat tendency was also rescaled. Also introduced combined integrated heat conversion variables in accumulate_net_input for simplicity. All answers are bitwise identical. --- src/core/MOM.F90 | 8 +++----- src/core/MOM_variables.F90 | 2 +- src/diagnostics/MOM_diagnostics.F90 | 6 +++--- src/diagnostics/MOM_sum_output.F90 | 14 ++++++++------ .../vertical/MOM_diabatic_driver.F90 | 10 +++++----- src/parameterizations/vertical/MOM_geothermal.F90 | 4 ++-- src/tracer/MOM_generic_tracer.F90 | 4 ++-- 7 files changed, 24 insertions(+), 24 deletions(-) diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index 3c85df46f0..fceec84cc9 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -2106,11 +2106,9 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & ! initialization routine for tv. if (use_EOS) call EOS_init(param_file, CS%tv%eqn_of_state) if (use_temperature) then - allocate(CS%tv%TempxPmE(isd:ied,jsd:jed)) - CS%tv%TempxPmE(:,:) = 0.0 + allocate(CS%tv%TempxPmE(isd:ied,jsd:jed)) ; CS%tv%TempxPmE(:,:) = 0.0 if (use_geothermal) then - allocate(CS%tv%internal_heat(isd:ied,jsd:jed)) - CS%tv%internal_heat(:,:) = 0.0 + allocate(CS%tv%internal_heat(isd:ied,jsd:jed)) ; CS%tv%internal_heat(:,:) = 0.0 endif endif call callTree_waypoint("state variables allocated (initialize_MOM)") @@ -2984,7 +2982,7 @@ subroutine extract_surface_state(CS, sfc_state) if (allocated(sfc_state%internal_heat) .and. associated(CS%tv%internal_heat)) then !$OMP parallel do default(shared) do j=js,je ; do i=is,ie - sfc_state%internal_heat(i,j) = CS%tv%internal_heat(i,j) + sfc_state%internal_heat(i,j) = US%R_to_kg_m3*US%Z_to_m*CS%tv%internal_heat(i,j) enddo ; enddo endif if (allocated(sfc_state%taux_shelf) .and. associated(CS%visc%taux_shelf)) then diff --git a/src/core/MOM_variables.F90 b/src/core/MOM_variables.F90 index ccf2fd3784..93fffb3c51 100644 --- a/src/core/MOM_variables.F90 +++ b/src/core/MOM_variables.F90 @@ -110,7 +110,7 @@ module MOM_variables real, dimension(:,:), pointer :: internal_heat => NULL() !< Any internal or geothermal heat sources that !! have been applied to the ocean since the last call to - !! calculate_surface_state [degC kg m-2]. + !! calculate_surface_state [degC R Z ~> degC kg m-2]. end type thermo_var_ptrs !> Pointers to all of the prognostic variables allocated in MOM_variables.F90 and MOM.F90. diff --git a/src/diagnostics/MOM_diagnostics.F90 b/src/diagnostics/MOM_diagnostics.F90 index 37efe52b1f..17996d785a 100644 --- a/src/diagnostics/MOM_diagnostics.F90 +++ b/src/diagnostics/MOM_diagnostics.F90 @@ -1291,7 +1291,7 @@ subroutine post_surface_thermo_diags(IDs, G, GV, US, diag, dt_int, sfc_state, tv ! Use TEOS-10 function calls convert T&S diagnostics from conservative temp ! to potential temperature. do j=js,je ; do i=is,ie - work_2d(i,j) = gsw_pt_from_ct(sfc_state%SSS(i,j),sfc_state%SST(i,j)) + work_2d(i,j) = gsw_pt_from_ct(sfc_state%SSS(i,j), sfc_state%SST(i,j)) enddo ; enddo if (IDs%id_sst > 0) call post_data(IDs%id_sst, work_2d, diag, mask=G%mask2dT) else @@ -1807,8 +1807,8 @@ subroutine register_surface_diags(Time, G, US, IDs, diag, tv) 'Heat flux into ocean from mass flux into ocean', & 'W m-2', conversion=US%QRZ_T_to_W_m2) IDs%id_intern_heat = register_diag_field('ocean_model', 'internal_heat', diag%axesT1, Time,& - 'Heat flux into ocean from geothermal or other internal sources', 'W m-2', & - conversion=US%Q_to_J_kg*US%s_to_T) + 'Heat flux into ocean from geothermal or other internal sources', & + 'W m-2', conversion=US%QRZ_T_to_W_m2) end subroutine register_surface_diags diff --git a/src/diagnostics/MOM_sum_output.F90 b/src/diagnostics/MOM_sum_output.F90 index 6afc60a6f2..9052b85aec 100644 --- a/src/diagnostics/MOM_sum_output.F90 +++ b/src/diagnostics/MOM_sum_output.F90 @@ -964,6 +964,7 @@ subroutine accumulate_net_input(fluxes, sfc_state, tv, dt, G, US, CS) ! over a time step and summed over space [J]. real :: C_p ! The heat capacity of seawater [J degC-1 kg-1]. real :: RZL2_to_kg ! A combination of scaling factors for mass [kg R-1 Z-1 L-2 ~> 1] + real :: QRZL2_to_J ! A combination of scaling factors for heat [J Q-1 R-1 Z-1 L-2 ~> 1] type(EFP_type) :: & FW_in_EFP, & ! Extended fixed point version of FW_input [kg] @@ -976,6 +977,7 @@ subroutine accumulate_net_input(fluxes, sfc_state, tv, dt, G, US, CS) is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec C_p = US%Q_to_J_kg*fluxes%C_p RZL2_to_kg = US%L_to_m**2*US%R_to_kg_m3*US%Z_to_m + QRZL2_to_J = RZL2_to_kg*US%Q_to_J_kg FW_in(:,:) = 0.0 ; FW_input = 0.0 if (associated(fluxes%evap)) then @@ -1000,19 +1002,19 @@ subroutine accumulate_net_input(fluxes, sfc_state, tv, dt, G, US, CS) if (CS%use_temperature) then if (associated(fluxes%sw)) then ; do j=js,je ; do i=is,ie - heat_in(i,j) = heat_in(i,j) + dt*US%T_to_s*US%L_to_m**2*US%QRZ_T_to_W_m2*G%areaT(i,j) * (fluxes%sw(i,j) + & + heat_in(i,j) = heat_in(i,j) + dt * QRZL2_to_J * G%areaT(i,j) * (fluxes%sw(i,j) + & (fluxes%lw(i,j) + (fluxes%latent(i,j) + fluxes%sens(i,j)))) enddo ; enddo ; endif if (associated(fluxes%seaice_melt_heat)) then ; do j=js,je ; do i=is,ie - heat_in(i,j) = heat_in(i,j) + dt*US%T_to_s*US%L_to_m**2*US%QRZ_T_to_W_m2*G%areaT(i,j) * & + heat_in(i,j) = heat_in(i,j) + dt * QRZL2_to_J * G%areaT(i,j) * & fluxes%seaice_melt_heat(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 -! heat_in(i,j) = heat_in(i,j) + dt*US%T_to_s*US%L_to_m**2*US%QRZ_T_to_W_m2*G%areaT(i,j) * & +! heat_in(i,j) = heat_in(i,j) + dt * QRZL2_to_J * 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) & ! + (fluxes%heat_content_cond(i,j) + (fluxes%heat_content_vprec(i,j) & @@ -1034,15 +1036,15 @@ subroutine accumulate_net_input(fluxes, sfc_state, tv, dt, G, US, CS) ! The following heat sources may or may not be used. if (associated(tv%internal_heat)) then do j=js,je ; do i=is,ie - heat_in(i,j) = heat_in(i,j) + (C_p * US%L_to_m**2*G%areaT(i,j)) * & + heat_in(i,j) = heat_in(i,j) + (C_p * RZL2_to_kg*G%areaT(i,j)) * & tv%internal_heat(i,j) enddo ; enddo endif if (associated(tv%frazil)) then ; do j=js,je ; do i=is,ie - heat_in(i,j) = heat_in(i,j) + US%L_to_m**2*G%areaT(i,j) * US%Q_to_J_kg*US%R_to_kg_m3*US%Z_to_m*tv%frazil(i,j) + heat_in(i,j) = heat_in(i,j) + QRZL2_to_J * G%areaT(i,j) * tv%frazil(i,j) enddo ; enddo ; endif if (associated(fluxes%heat_added)) then ; do j=js,je ; do i=is,ie - heat_in(i,j) = heat_in(i,j) + RZL2_to_kg*US%Q_to_J_kg * dt*G%areaT(i,j) * fluxes%heat_added(i,j) + heat_in(i,j) = heat_in(i,j) + QRZL2_to_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 ! heat_in(i,j) = heat_in(i,j) - US%L_to_m**2*G%areaT(i,j) * sfc_state%sw_lost(i,j) diff --git a/src/parameterizations/vertical/MOM_diabatic_driver.F90 b/src/parameterizations/vertical/MOM_diabatic_driver.F90 index 2505c5677c..022eb70f1b 100644 --- a/src/parameterizations/vertical/MOM_diabatic_driver.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_driver.F90 @@ -3049,8 +3049,7 @@ subroutine diagnose_boundary_forcing_tendency(tv, h, temp_old, saln_old, h_old, ! heat tendency 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) = US%Q_to_J_kg*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)) + work_3d(i,j,k) = 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 call post_data(CS%id_boundary_forcing_heat_tend, work_3d, CS%diag, alt_h = h_old) @@ -3617,8 +3616,8 @@ subroutine diabatic_driver_init(Time, G, GV, US, param_file, useALEalgorithm, di CS%id_boundary_forcing_heat_tend = register_diag_field('ocean_model',& 'boundary_forcing_heat_tendency', diag%axesTL, Time, & - 'Boundary forcing heat tendency', 'W m-2', conversion=US%s_to_T, & - v_extensive = .true.) + 'Boundary forcing heat tendency', & + 'W m-2', conversion=US%QRZ_T_to_W_m2*GV%H_to_RZ, v_extensive = .true.) if (CS%id_boundary_forcing_heat_tend > 0) then CS%boundary_forcing_tendency_diag = .true. endif @@ -3634,7 +3633,8 @@ subroutine diabatic_driver_init(Time, G, GV, US, param_file, useALEalgorithm, di ! This diagnostic should equal to surface heat flux if all is working well. CS%id_boundary_forcing_heat_tend_2d = register_diag_field('ocean_model',& 'boundary_forcing_heat_tendency_2d', diag%axesT1, Time, & - 'Depth integrated boundary forcing of ocean heat', 'W m-2', conversion=US%s_to_T) + 'Depth integrated boundary forcing of ocean heat', & + 'W m-2', conversion=US%QRZ_T_to_W_m2*GV%H_to_RZ) if (CS%id_boundary_forcing_heat_tend_2d > 0) then CS%boundary_forcing_tendency_diag = .true. endif diff --git a/src/parameterizations/vertical/MOM_geothermal.F90 b/src/parameterizations/vertical/MOM_geothermal.F90 index b59b45431d..638197f97c 100644 --- a/src/parameterizations/vertical/MOM_geothermal.F90 +++ b/src/parameterizations/vertical/MOM_geothermal.F90 @@ -345,7 +345,7 @@ subroutine geothermal(h, tv, dt, ea, eb, G, GV, US, CS, halo) enddo ! k-loop if (associated(tv%internal_heat)) then ; do i=is,ie - tv%internal_heat(i,j) = tv%internal_heat(i,j) + GV%H_to_kg_m2 * & + tv%internal_heat(i,j) = tv%internal_heat(i,j) + GV%H_to_RZ * & (G%mask2dT(i,j) * (CS%geo_heat(i,j) * (dt*Irho_cp)) - heat_rem(i)) enddo ; endif enddo ! j-loop @@ -368,7 +368,7 @@ subroutine geothermal(h, tv, dt, ea, eb, G, GV, US, CS, halo) endif ! do i=is,ie ; do j=js,je -! resid(i,j) = tv%internal_heat(i,j) - resid(i,j) - GV%H_to_kg_m2 * & +! resid(i,j) = tv%internal_heat(i,j) - resid(i,j) - GV%H_to_RZ * & ! (G%mask2dT(i,j) * (CS%geo_heat(i,j) * (dt*Irho_cp))) ! enddo ; enddo diff --git a/src/tracer/MOM_generic_tracer.F90 b/src/tracer/MOM_generic_tracer.F90 index 3cd81de052..a1dd74a265 100644 --- a/src/tracer/MOM_generic_tracer.F90 +++ b/src/tracer/MOM_generic_tracer.F90 @@ -493,10 +493,10 @@ subroutine MOM_generic_tracer_column_physics(h_old, h_new, ea, eb, fluxes, Hml, !Calculate tendencies (i.e., field changes at dt) from the sources / sinks ! - call generic_tracer_source(tv%T,tv%S,rho_dzt,dzt,Hml,G%isd,G%jsd,1,dt,& + call generic_tracer_source(tv%T, tv%S, rho_dzt, dzt, Hml, G%isd, G%jsd, 1, dt, & G%US%L_to_m**2*G%areaT(:,:), get_diag_time_end(CS%diag), & optics%nbands, optics%max_wavelength_band, optics%sw_pen_band, optics%opacity_band, & - internal_heat=tv%internal_heat, & + internal_heat=G%US%R_to_kg_m3*G%US%Z_to_m*tv%internal_heat(:,:), & frunoff=G%US%R_to_kg_m3*G%US%Z_to_m*G%US%s_to_T*fluxes%frunoff(:,:), sosga=sosga) ! This uses applyTracerBoundaryFluxesInOut to handle the change in tracer due to freshwater fluxes From bca6ed8227f7c503c648a3fe8ab37cb8ce79327e Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sat, 22 Feb 2020 15:09:22 -0500 Subject: [PATCH 078/316] Updates to ice_solo_driver/MOM_surface_forcing.F90 Copied code and comments into ice_solo_driver/MOM_surface_forcing.F90 from its counterpart in solo_driver. There are now dOxygen comments describing the elements of the control structure for this modul. This code is neither used nor tested, and it would not even have compiled without these changes. Perhaps the whole ice_solo_driver directory should be deleted. All answers in the MOM6-examples test cases are bitwise identical. --- .../ice_solo_driver/MOM_surface_forcing.F90 | 162 ++++++++++-------- 1 file changed, 93 insertions(+), 69 deletions(-) diff --git a/config_src/ice_solo_driver/MOM_surface_forcing.F90 b/config_src/ice_solo_driver/MOM_surface_forcing.F90 index 38001f9812..4f7feb4e98 100644 --- a/config_src/ice_solo_driver/MOM_surface_forcing.F90 +++ b/config_src/ice_solo_driver/MOM_surface_forcing.F90 @@ -46,6 +46,8 @@ module MOM_surface_forcing !* The boundaries always run through q grid points (x). * !* * !********+*********+*********+*********+*********+*********+*********+** + +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_MODULE use MOM_diag_mediator, only : post_data, query_averaging_enabled @@ -89,72 +91,89 @@ module MOM_surface_forcing ! which may be used to drive MOM. All fluxes are positive into the ocean. type, public :: surface_forcing_CS ; private - logical :: use_temperature ! if true, temp & salinity used as state variables - logical :: restorebuoy ! if true, use restoring surface buoyancy forcing - logical :: adiabatic ! if true, no diapycnal mass fluxes or surface buoyancy forcing - logical :: variable_winds ! if true, wind stresses vary with time - logical :: variable_buoyforce ! if true, buoyancy forcing varies with time. - real :: south_lat ! southern latitude of the domain - real :: len_lat ! domain length in latitude - - real :: Rho0 ! Boussinesq reference density [R ~> kg m-3] - real :: G_Earth ! gravitational acceleration [L2 Z-1 T-2 ~> m s-2] - real :: Flux_const ! piston velocity for surface restoring [Z T-1 ~> m s-1] - - real :: gust_const ! constant unresolved background gustiness for ustar [R L Z T-1 ~> Pa] - logical :: read_gust_2d ! if true, use 2-dimensional gustiness supplied from a file - real, pointer :: gust(:,:) => NULL() ! spatially varying unresolved background gustiness [R L Z T-1 ~> Pa] - ! gust is used when read_gust_2d is true. - - real, pointer :: T_Restore(:,:) => NULL() ! temperature to damp (restore) the SST to [degC] - real, pointer :: S_Restore(:,:) => NULL() ! salinity to damp (restore) the SSS [ppt] - real, pointer :: Dens_Restore(:,:) => NULL() ! density to damp (restore) surface density [kg m-3] - - integer :: wind_last_lev_read = -1 ! The last time level read from the wind input files - integer :: buoy_last_lev_read = -1 ! The last time level read from buoyancy input files - - real :: gyres_taux_const, gyres_taux_sin_amp, gyres_taux_cos_amp, gyres_taux_n_pis - ! if WIND_CONFIG=='gyres' then use - ! = A, B, C and n respectively for - ! taux = A + B*sin(n*pi*y/L) + C*cos(n*pi*y/L) - - real :: T_north, T_south ! target temperatures at north and south used in - ! buoyancy_forcing_linear - real :: S_north, S_south ! target salinity at north and south used in - ! buoyancy_forcing_linear - - logical :: first_call_set_forcing = .true. - real :: wind_scale ! value by which wind-stresses are scaled (nondimensional) - character(len=8) :: wind_stagger - - type(tracer_flow_control_CS), pointer :: tracer_flow_CSp => NULL() - type(MOM_restart_CS), pointer :: restart_CSp => NULL() - - type(diag_ctrl), pointer :: diag ! structure used to regulate timing of diagnostic output - - character(len=200) :: inputdir ! The directory where NetCDF input files are. - character(len=200) :: wind_config ! Indicator for wind forcing type (2gyre, USER, FILE..) - character(len=200) :: wind_file ! If wind_config is "file", file to use - character(len=200) :: buoy_config ! Indicator for buoyancy forcing type - character(len=200) :: longwavedown_file - character(len=200) :: longwaveup_file - character(len=200) :: evaporation_file - character(len=200) :: sensibleheat_file - character(len=200) :: shortwaveup_file - character(len=200) :: shortwavedown_file - character(len=200) :: snow_file - character(len=200) :: precip_file - character(len=200) :: freshdischarge_file - character(len=200) :: SSTrestore_file - character(len=200) :: salinityrestore_file - character(len=80) :: stress_x_var, stress_y_var - - ! Diagnostics handles - type(forcing_diags), public :: handles - - type(user_revise_forcing_CS), pointer :: urf_CS => NULL() - type(user_surface_forcing_CS), pointer :: user_forcing_CSp => NULL() -! type(MESO_surface_forcing_CS), pointer :: MESO_forcing_CSp => NULL() + logical :: use_temperature !< if true, temp & salinity used as state variables + logical :: restorebuoy !< if true, use restoring surface buoyancy forcing + logical :: adiabatic !< if true, no diapycnal mass fluxes or surface buoyancy forcing + logical :: variable_winds !< if true, wind stresses vary with time + logical :: variable_buoyforce !< if true, buoyancy forcing varies with time. + real :: south_lat !< southern latitude of the domain + real :: len_lat !< domain length in latitude + + real :: Rho0 !< Boussinesq reference density [R ~> kg m-3] + real :: G_Earth !< gravitational acceleration [L2 Z-1 T-2 ~> m s-2] + real :: Flux_const !< piston velocity for surface restoring [Z T-1 ~> m s-1] + real :: latent_heat_fusion !< latent heat of fusion times [Q ~> J kg-1] + real :: latent_heat_vapor !< latent heat of vaporization [Q ~> J kg-1] + + real :: gust_const !< constant unresolved background gustiness for ustar [R L Z T-1 ~> Pa] + logical :: read_gust_2d !< if true, use 2-dimensional gustiness supplied from a file + real, pointer :: gust(:,:) => NULL() !< spatially varying unresolved background gustiness [R L Z T-1 ~> Pa] + !< gust is used when read_gust_2d is true. + + real, pointer :: T_Restore(:,:) => NULL() !< temperature to damp (restore) the SST to [degC] + real, pointer :: S_Restore(:,:) => NULL() !< salinity to damp (restore) the SSS [ppt] + real, pointer :: Dens_Restore(:,:) => NULL() !< density to damp (restore) surface density [kg m-3] + + integer :: wind_last_lev_read = -1 !< The last time level read from the wind input files + integer :: buoy_last_lev_read = -1 !< The last time level read from buoyancy input files + + ! if WIND_CONFIG=='gyres' then use the following as = A, B, C and n respectively for + ! taux = A + B*sin(n*pi*y/L) + C*cos(n*pi*y/L) + real :: gyres_taux_const !< A constant wind stress [Pa]. + real :: gyres_taux_sin_amp !< The amplitude of cosine wind stress gyres [Pa], if WIND_CONFIG=='gyres'. + real :: gyres_taux_cos_amp !< The amplitude of cosine wind stress gyres [Pa], if WIND_CONFIG=='gyres'. + real :: gyres_taux_n_pis !< The number of sine lobes in the basin if if WIND_CONFIG=='gyres' + + real :: T_north !< target temperatures at north used in buoyancy_forcing_linear + real :: T_south !< target temperatures at south used in buoyancy_forcing_linear + real :: S_north !< target salinity at north used in buoyancy_forcing_linear + real :: S_south !< target salinity at south used in buoyancy_forcing_linear + + logical :: first_call_set_forcing = .true. !< True until after the first call to set_forcing + + real :: wind_scale !< value by which wind-stresses are scaled, ND. + character(len=8) :: wind_stagger !< A character indicating how the wind stress components + !! are staggered in WIND_FILE. Valid values are A or C for now. + + type(tracer_flow_control_CS), pointer :: tracer_flow_CSp => NULL() !< A pointer to the structure + !! that is used to orchestrate the calling of tracer packages + type(MOM_restart_CS), pointer :: restart_CSp => NULL() !< A pointer to the restart control structure + + type(diag_ctrl), pointer :: diag !< structure used to regulate timing of diagnostic output + + character(len=200) :: inputdir !< directory where NetCDF input files are. + character(len=200) :: wind_config !< indicator for wind forcing type (2gyre, USER, FILE..) + character(len=200) :: wind_file !< if wind_config is "file", file to use + character(len=200) :: buoy_config !< indicator for buoyancy forcing type + + character(len=200) :: longwavedown_file = '' !< The file from which the downward longwave heat flux is read + character(len=200) :: shortwavedown_file = '' !< The file from which the downward shortwave heat flux is read + character(len=200) :: evaporation_file = '' !< The file from which the evaporation is read + character(len=200) :: sensibleheat_file = '' !< The file from which the sensible heat flux is read + character(len=200) :: latentheat_file = '' !< The file from which the latent heat flux is read + + character(len=200) :: precip_file = '' !< The file from which the rainfall is read + character(len=200) :: snow_file = '' !< The file from which the snowfall is read + character(len=200) :: freshdischarge_file = '' !< The file from which the runoff and calving are read + + character(len=200) :: longwaveup_file = '' !< The file from which the upward longwave heat flux is read + character(len=200) :: shortwaveup_file = '' !< The file from which the upward shorwave heat flux is read + + character(len=200) :: SSTrestore_file = '' !< The file from which to read the sea surface + !! temperature to restore toward + character(len=200) :: salinityrestore_file = '' !< The file from which to read the sea surface + !! salinity to restore toward + + character(len=80) :: stress_x_var = '' !< X-windstress variable name in the input file + character(len=80) :: stress_y_var = '' !< Y-windstress variable name in the input file + + type(forcing_diags), public :: handles !< A structure with diagnostics handles + + !>@{ Control structures for named forcing packages + type(user_revise_forcing_CS), pointer :: urf_CS => NULL() + type(user_surface_forcing_CS), pointer :: user_forcing_CSp => NULL() + ! type(MESO_surface_forcing_CS), pointer :: MESO_forcing_CSp => NULL() + !!@} end type surface_forcing_CS integer :: id_clock_forcing @@ -670,7 +689,7 @@ subroutine buoyancy_forcing_from_files(sfc_state, fluxes, day, dt, G, US, CS) call MOM_read_data(trim(CS%inputdir)//trim(CS%evaporation_file), "evap", & fluxes%evap(:,:), G%Domain, timelevel=time_lev, scale=-US%kg_m3_to_R*US%m_to_Z*US%T_to_s) do j=js,je ; do i=is,ie - fluxes%latent(i,j) = US%J_kg_to_Q*hlv*fluxes%evap(i,j) + fluxes%latent(i,j) = CS%latent_heat_vapor*fluxes%evap(i,j) fluxes%latent_evap_diag(i,j) = fluxes%latent(i,j) enddo ; enddo @@ -731,8 +750,8 @@ subroutine buoyancy_forcing_from_files(sfc_state, fluxes, day, dt, G, US, CS) fluxes%heat_content_lrunoff(i,j) = fluxes%C_p * fluxes%lrunoff(i,j)*sfc_state%SST(i,j) fluxes%latent_evap_diag(i,j) = fluxes%latent_evap_diag(i,j) * G%mask2dT(i,j) - fluxes%latent_fprec_diag(i,j) = -fluxes%fprec(i,j)*US%J_kg_to_Q*hlf - fluxes%latent_frunoff_diag(i,j) = -fluxes%frunoff(i,j)*US%J_kg_to_Q*hlf + fluxes%latent_fprec_diag(i,j) = -fluxes%fprec(i,j)*CS%latent_heat_fusion + fluxes%latent_frunoff_diag(i,j) = -fluxes%frunoff(i,j)*CS%latent_heat_fusion enddo ; enddo endif ! time_lev /= CS%buoy_last_lev_read @@ -1084,6 +1103,11 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, tracer_flow_C "If true, the buoyancy fluxes drive the model back "//& "toward some specified surface state with a rate "//& "given by FLUXCONST.", default= .false.) + call get_param(param_file, mdl, "LATENT_HEAT_FUSION", CS%latent_heat_fusion, & + "The latent heat of fusion.", default=hlf, & + units="J/kg", scale=US%J_kg_to_Q) + call get_param(param_file, mdl, "LATENT_HEAT_VAPORIZATION", CS%latent_heat_vapor, & + "The latent heat of fusion.", default=hlv, units="J/kg", scale=US%J_kg_to_Q) if (CS%restorebuoy) then call get_param(param_file, mdl, "FLUXCONST", CS%Flux_const, & "The constant that relates the restoring surface fluxes "//& From fd412180844fa33720668b029cb4d04c6a561c78 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sat, 22 Feb 2020 15:52:54 -0500 Subject: [PATCH 079/316] Added logical tests around generic_tracer_source Added logical tests around the call to generic_tracer_source in MOM_generic_tracer_column_physics to avoid unnecessary array-syntax copies when there is no rescaling of variables. All answers are bitwise identical. --- src/tracer/MOM_generic_tracer.F90 | 19 +++++++++++++------ 1 file changed, 13 insertions(+), 6 deletions(-) diff --git a/src/tracer/MOM_generic_tracer.F90 b/src/tracer/MOM_generic_tracer.F90 index a1dd74a265..cae084f120 100644 --- a/src/tracer/MOM_generic_tracer.F90 +++ b/src/tracer/MOM_generic_tracer.F90 @@ -492,12 +492,19 @@ subroutine MOM_generic_tracer_column_physics(h_old, h_new, ea, eb, fluxes, Hml, ! !Calculate tendencies (i.e., field changes at dt) from the sources / sinks ! - - call generic_tracer_source(tv%T, tv%S, rho_dzt, dzt, Hml, G%isd, G%jsd, 1, dt, & - G%US%L_to_m**2*G%areaT(:,:), get_diag_time_end(CS%diag), & - optics%nbands, optics%max_wavelength_band, optics%sw_pen_band, optics%opacity_band, & - internal_heat=G%US%R_to_kg_m3*G%US%Z_to_m*tv%internal_heat(:,:), & - frunoff=G%US%R_to_kg_m3*G%US%Z_to_m*G%US%s_to_T*fluxes%frunoff(:,:), sosga=sosga) + if ((G%US%L_to_m == 1.0) .and. (G%US%R_to_kg_m3*G%US%Z_to_m == 1.0) .and. (G%US%s_to_T == 1.0)) then + ! Avoid unnecessary copies when no unit conversion is needed. + call generic_tracer_source(tv%T, tv%S, rho_dzt, dzt, Hml, G%isd, G%jsd, 1, dt, & + G%areaT, get_diag_time_end(CS%diag), & + optics%nbands, optics%max_wavelength_band, optics%sw_pen_band, optics%opacity_band, & + internal_heat=tv%internal_heat, frunoff=fluxes%frunoff, sosga=sosga) + else + call generic_tracer_source(tv%T, tv%S, rho_dzt, dzt, Hml, G%isd, G%jsd, 1, dt, & + G%US%L_to_m**2*G%areaT(:,:), get_diag_time_end(CS%diag), & + optics%nbands, optics%max_wavelength_band, optics%sw_pen_band, optics%opacity_band, & + internal_heat=G%US%R_to_kg_m3*G%US%Z_to_m*tv%internal_heat(:,:), & + frunoff=G%US%R_to_kg_m3*G%US%Z_to_m*G%US%s_to_T*fluxes%frunoff(:,:), sosga=sosga) + endif ! This uses applyTracerBoundaryFluxesInOut to handle the change in tracer due to freshwater fluxes ! usually in ALE mode From 0f0b85c8e1a02a89290c68f85a99002aed47b286 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sat, 22 Feb 2020 15:59:02 -0500 Subject: [PATCH 080/316] Rescaled variables in MOM_sum_output Rescaled the area and volume variables in MOM_sum_output, among others, for expanded dimensional consistency testing and code simplification. With these changes the rescaling factors are still present but have been collected onto fewer lines. All answers are bitwise identical. --- src/diagnostics/MOM_sum_output.F90 | 82 +++++++++++++++--------------- 1 file changed, 41 insertions(+), 41 deletions(-) diff --git a/src/diagnostics/MOM_sum_output.F90 b/src/diagnostics/MOM_sum_output.F90 index 9052b85aec..6a0334e3ac 100644 --- a/src/diagnostics/MOM_sum_output.F90 +++ b/src/diagnostics/MOM_sum_output.F90 @@ -52,9 +52,9 @@ module MOM_sum_output !> A list of depths and corresponding globally integrated ocean area at each !! depth and the ocean volume below each depth. type :: Depth_List - real :: depth !< A depth [m]. - real :: area !< The cross-sectional area of the ocean at that depth [m2]. - real :: vol_below !< The ocean volume below that depth [m3]. + real :: depth !< A depth [Z ~> m]. + real :: area !< The cross-sectional area of the ocean at that depth [L2 ~> m2]. + real :: vol_below !< The ocean volume below that depth [Z m2 ~> m3]. end type Depth_List !> The control structure for the MOM_sum_output module @@ -324,7 +324,7 @@ subroutine write_energy(u, v, h, tv, day, n, G, GV, US, CS, tracer_CSp, OBC, dt_ type(time_type), optional, intent(in) :: dt_forcing !< The forcing time step ! Local variables real :: eta(SZI_(G),SZJ_(G),SZK_(G)+1) ! The height of interfaces [Z ~> m]. - real :: areaTm(SZI_(G),SZJ_(G)) ! A masked version of areaT [m2]. + real :: areaTm(SZI_(G),SZJ_(G)) ! A masked version of areaT [L2 ~> m2]. real :: KE(SZK_(G)) ! The total kinetic energy of a layer [J]. real :: PE(SZK_(G)+1)! The available potential energy of an interface [J]. real :: KE_tot ! The total kinetic energy [J]. @@ -336,8 +336,8 @@ subroutine write_energy(u, v, h, tv, day, n, G, GV, US, CS, tracer_CSp, OBC, dt_ ! all layers [J] (i.e. kg m2 s-2). real :: En_mass ! The total kinetic and potential energies divided by ! the total mass of the ocean [m2 s-2]. - real :: vol_lay(SZK_(G)) ! The volume of fluid in a layer [Z m2 ~> m3]. - real :: volbelow ! The volume of all layers beneath an interface [Z m2 ~> m3]. + real :: vol_lay(SZK_(G)) ! The volume of fluid in a layer [Z L2 ~> m3]. + real :: volbelow ! The volume of all layers beneath an interface [Z L2 ~> m3]. real :: mass_lay(SZK_(G)) ! The mass of fluid in a layer [kg]. real :: mass_tot ! The total mass of the ocean [kg]. real :: vol_tot ! The total ocean volume [m3]. @@ -386,9 +386,11 @@ subroutine write_energy(u, v, h, tv, day, n, G, GV, US, CS, tracer_CSp, OBC, dt_ PE_pt ! The potential energy at each point [J]. real, dimension(SZI_(G),SZJ_(G)) :: & Temp_int, Salt_int ! Layer and cell integrated heat and salt [J] and [g Salt]. - real :: H_to_kg_m2 ! Local copy of a unit conversion factor. + real :: HL2_to_kg ! A conversion factor form a thickness-volume to mass [kg H-1 L-2 ~> kg m-3 or 1] real :: KE_scale_factor ! The combination of unit rescaling factors in the kinetic energy - ! calculation [kg T2 L-2 s-2 H-1 ~> kg m-3 or nondim] + ! calculation [kg T2 H-1 L-2 s-2 ~> kg m-3 or nondim] + real :: PE_scale_factor ! The combination of unit rescaling factors in the potential energy + ! calculation [kg T2 R-1 Z-1 L-2 s-2 ~> nondim] integer :: num_nc_fields ! The number of fields that will actually go into ! the NetCDF file. integer :: i, j, k, is, ie, js, je, ns, nz, m, Isq, Ieq, Jsq, Jeq @@ -479,19 +481,20 @@ subroutine write_energy(u, v, h, tv, day, n, G, GV, US, CS, tracer_CSp, OBC, 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 - H_to_kg_m2 = GV%H_to_kg_m2 + + HL2_to_kg = GV%H_to_kg_m2*US%L_to_m**2 if (.not.associated(CS)) call MOM_error(FATAL, & "write_energy: Module must be initialized before it is used.") do j=js,je ; do i=is,ie - areaTm(i,j) = G%mask2dT(i,j)*US%L_to_m**2*G%areaT(i,j) + areaTm(i,j) = G%mask2dT(i,j)*G%areaT(i,j) enddo ; enddo if (GV%Boussinesq) then tmp1(:,:,:) = 0.0 do k=1,nz ; do j=js,je ; do i=is,ie - tmp1(i,j,k) = h(i,j,k) * (H_to_kg_m2*areaTm(i,j)) + tmp1(i,j,k) = h(i,j,k) * (HL2_to_kg*areaTm(i,j)) enddo ; enddo ; enddo ! This block avoids using the points beyond an open boundary condition @@ -523,27 +526,27 @@ subroutine write_energy(u, v, h, tv, day, n, G, GV, US, CS, tracer_CSp, OBC, dt_ endif mass_tot = reproducing_sum(tmp1, sums=mass_lay, EFP_sum=mass_EFP) - do k=1,nz ; vol_lay(k) = (GV%H_to_Z/H_to_kg_m2)*mass_lay(k) ; enddo + do k=1,nz ; vol_lay(k) = (US%m_to_L**2*GV%H_to_Z/GV%H_to_kg_m2)*mass_lay(k) ; enddo else tmp1(:,:,:) = 0.0 if (CS%do_APE_calc) then do k=1,nz ; do j=js,je ; do i=is,ie - tmp1(i,j,k) = H_to_kg_m2 * h(i,j,k) * areaTm(i,j) + tmp1(i,j,k) = HL2_to_kg * h(i,j,k) * areaTm(i,j) enddo ; enddo ; enddo mass_tot = reproducing_sum(tmp1, sums=mass_lay, EFP_sum=mass_EFP) call find_eta(h, tv, G, GV, US, eta) do k=1,nz ; do j=js,je ; do i=is,ie - tmp1(i,j,k) = US%Z_to_m*(eta(i,j,K)-eta(i,j,K+1)) * areaTm(i,j) + tmp1(i,j,k) = US%Z_to_m*US%L_to_m**2*(eta(i,j,K)-eta(i,j,K+1)) * areaTm(i,j) enddo ; enddo ; enddo vol_tot = reproducing_sum(tmp1, sums=vol_lay) - do k=1,nz ; vol_lay(k) = US%m_to_Z * vol_lay(k) ; enddo + do k=1,nz ; vol_lay(k) = US%m_to_Z*US%m_to_L**2 * vol_lay(k) ; enddo else do k=1,nz ; do j=js,je ; do i=is,ie - tmp1(i,j,k) = H_to_kg_m2 * h(i,j,k) * areaTm(i,j) + tmp1(i,j,k) = HL2_to_kg * h(i,j,k) * areaTm(i,j) enddo ; enddo ; enddo mass_tot = reproducing_sum(tmp1, sums=mass_lay, EFP_sum=mass_EFP) - do k=1,nz ; vol_lay(k) = US%m_to_Z * (mass_lay(k) / (US%R_to_kg_m3*GV%Rho0)) ; enddo + do k=1,nz ; vol_lay(k) = US%m_to_Z*US%m_to_L**2*US%kg_m3_to_R * (mass_lay(k) / GV%Rho0) ; enddo endif endif ! Boussinesq @@ -654,10 +657,10 @@ subroutine write_energy(u, v, h, tv, day, n, G, GV, US, CS, tracer_CSp, OBC, dt_ enddo Z_0APE(nz+1) = CS%DL(2)%depth - ! Calculate the Available Potential Energy integrated over each - ! interface. With a nonlinear equation of state or with a bulk - ! mixed layer this calculation is only approximate. With an ALE model - ! this does not make sense. + ! Calculate the Available Potential Energy integrated over each interface. With a nonlinear + ! equation of state or with a bulk mixed layer this calculation is only approximate. + ! With an ALE model this does not make sense and should be revisited. + PE_scale_factor = US%Z_to_m*US%L_to_m**2*US%L_T_to_m_s**2*US%R_to_kg_m3 PE_pt(:,:,:) = 0.0 if (GV%Boussinesq) then do j=js,je ; do i=is,ie @@ -667,7 +670,7 @@ subroutine write_energy(u, v, h, tv, day, n, G, GV, US, CS, tracer_CSp, OBC, dt_ hint = Z_0APE(K) + (hbelow - G%bathyT(i,j)) hbot = Z_0APE(K) - G%bathyT(i,j) hbot = (hbot + ABS(hbot)) * 0.5 - PE_pt(i,j,K) = 0.5 * areaTm(i,j) * US%Z_to_m*US%L_T_to_m_s**2*(US%R_to_kg_m3*GV%Rho0*GV%g_prime(K)) * & + PE_pt(i,j,K) = (0.5 * PE_scale_factor * areaTm(i,j)) * (GV%Rho0*GV%g_prime(K)) * & (hint * hint - hbot * hbot) enddo enddo ; enddo @@ -676,7 +679,7 @@ subroutine write_energy(u, v, h, tv, day, n, G, GV, US, CS, tracer_CSp, OBC, dt_ do k=nz,1,-1 hint = Z_0APE(K) + eta(i,j,K) ! eta and H_0 have opposite signs. hbot = max(Z_0APE(K) - G%bathyT(i,j), 0.0) - PE_pt(i,j,K) = 0.5 * (areaTm(i,j) * US%Z_to_m*US%L_T_to_m_s**2*(US%R_to_kg_m3*GV%Rho0*GV%g_prime(K))) * & + PE_pt(i,j,K) = (0.5 * PE_scale_factor * areaTm(i,j) * (GV%Rho0*GV%g_prime(K))) * & (hint * hint - hbot * hbot) enddo enddo ; enddo @@ -690,7 +693,7 @@ subroutine write_energy(u, v, h, tv, day, n, G, GV, US, CS, tracer_CSp, OBC, dt_ endif ! Calculate the Kinetic Energy integrated over each layer. - KE_scale_factor = GV%H_to_kg_m2*US%L_T_to_m_s**2 + KE_scale_factor = HL2_to_kg*US%L_T_to_m_s**2 tmp1(:,:,:) = 0.0 do k=1,nz ; do j=js,je ; do i=is,ie tmp1(i,j,k) = (0.25 * KE_scale_factor * (areaTm(i,j) * h(i,j,k))) * & @@ -705,9 +708,9 @@ subroutine write_energy(u, v, h, tv, day, n, G, GV, US, CS, tracer_CSp, OBC, dt_ Temp_int(:,:) = 0.0 ; Salt_int(:,:) = 0.0 do k=1,nz ; do j=js,je ; do i=is,ie Salt_int(i,j) = Salt_int(i,j) + tv%S(i,j,k) * & - (h(i,j,k)*(H_to_kg_m2 * areaTm(i,j))) + (h(i,j,k)*(HL2_to_kg * areaTm(i,j))) Temp_int(i,j) = Temp_int(i,j) + (US%Q_to_J_kg*tv%C_p * tv%T(i,j,k)) * & - (h(i,j,k)*(H_to_kg_m2 * areaTm(i,j))) + (h(i,j,k)*(HL2_to_kg * areaTm(i,j))) enddo ; enddo ; enddo Salt = reproducing_sum(Salt_int, EFP_sum=salt_EFP) Heat = reproducing_sum(Temp_int, EFP_sum=heat_EFP) @@ -962,7 +965,6 @@ subroutine accumulate_net_input(fluxes, sfc_state, tv, dt, G, US, CS) ! over a time step and summed over space [ppt kg]. real :: heat_input ! The total heat added by boundary fluxes, integrated ! over a time step and summed over space [J]. - real :: C_p ! The heat capacity of seawater [J degC-1 kg-1]. real :: RZL2_to_kg ! A combination of scaling factors for mass [kg R-1 Z-1 L-2 ~> 1] real :: QRZL2_to_J ! A combination of scaling factors for heat [J Q-1 R-1 Z-1 L-2 ~> 1] @@ -975,7 +977,7 @@ subroutine accumulate_net_input(fluxes, sfc_state, tv, dt, G, US, CS) integer :: i, j, is, ie, js, je is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec - C_p = US%Q_to_J_kg*fluxes%C_p + RZL2_to_kg = US%L_to_m**2*US%R_to_kg_m3*US%Z_to_m QRZL2_to_J = RZL2_to_kg*US%Q_to_J_kg @@ -1024,20 +1026,18 @@ subroutine accumulate_net_input(fluxes, sfc_state, tv, dt, G, US, CS) ! smg: old code if (associated(tv%TempxPmE)) then do j=js,je ; do i=is,ie - heat_in(i,j) = heat_in(i,j) + (C_p * RZL2_to_kg*G%areaT(i,j)) * tv%TempxPmE(i,j) + heat_in(i,j) = heat_in(i,j) + (fluxes%C_p * QRZL2_to_J*G%areaT(i,j)) * tv%TempxPmE(i,j) enddo ; enddo 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) + heat_in(i,j) = heat_in(i,j) + (US%Q_to_J_kg*fluxes%C_p * sfc_state%SST(i,j)) * FW_in(i,j) enddo ; enddo endif - ! The following heat sources may or may not be used. if (associated(tv%internal_heat)) then do j=js,je ; do i=is,ie - heat_in(i,j) = heat_in(i,j) + (C_p * RZL2_to_kg*G%areaT(i,j)) * & - tv%internal_heat(i,j) + heat_in(i,j) = heat_in(i,j) + (fluxes%C_p * QRZL2_to_J*G%areaT(i,j)) * tv%internal_heat(i,j) enddo ; enddo endif if (associated(tv%frazil)) then ; do j=js,je ; do i=is,ie @@ -1115,13 +1115,13 @@ subroutine create_depth_list(G, CS) ! Local variables real, dimension(G%Domain%niglobal*G%Domain%njglobal + 1) :: & Dlist, & !< The global list of bottom depths [Z ~> m]. - AreaList !< The global list of cell areas [m2]. + AreaList !< The global list of cell areas [L2 ~> m2]. integer, dimension(G%Domain%niglobal*G%Domain%njglobal+1) :: & indx2 !< The position of an element in the original unsorted list. real :: Dnow !< The depth now being considered for sorting [Z ~> m]. real :: Dprev !< The most recent depth that was considered [Z ~> m]. - real :: vol !< The running sum of open volume below a deptn [Z m2 ~> m3]. - real :: area !< The open area at the current depth [m2]. + real :: vol !< The running sum of open volume below a deptn [Z L2 ~> m3]. + real :: area !< The open area at the current depth [L2 ~> m2]. real :: D_list_prev !< The most recent depth added to the list [Z ~> m]. logical :: add_to_list !< This depth should be included as an entry on the list. @@ -1142,7 +1142,7 @@ subroutine create_depth_list(G, CS) list_pos = (j_global-1)*G%Domain%niglobal + i_global Dlist(list_pos) = G%bathyT(i,j) - Arealist(list_pos) = G%mask2dT(i,j) * G%US%L_to_m**2*G%areaT(i,j) + Arealist(list_pos) = G%mask2dT(i,j) * G%areaT(i,j) enddo ; enddo ! These sums reproduce across PEs because the arrays are only nonzero on one PE. @@ -1310,12 +1310,12 @@ subroutine write_depth_list(G, US, CS, filename, list_size) if (status /= NF90_NOERR) call MOM_error(WARNING, & filename//" depth "//trim(NF90_STRERROR(status))) - do k=1,list_size ; tmp(k) = CS%DL(k)%area ; enddo + do k=1,list_size ; tmp(k) = US%L_to_m**2*CS%DL(k)%area ; enddo status = NF90_PUT_VAR(ncid, Aid, tmp) if (status /= NF90_NOERR) call MOM_error(WARNING, & filename//" area "//trim(NF90_STRERROR(status))) - do k=1,list_size ; tmp(k) = US%Z_to_m*CS%DL(k)%vol_below ; enddo + do k=1,list_size ; tmp(k) = US%Z_to_m*US%L_to_m**2*CS%DL(k)%vol_below ; enddo status = NF90_PUT_VAR(ncid, Vid, tmp) if (status /= NF90_NOERR) call MOM_error(WARNING, & filename//" vol_below "//trim(NF90_STRERROR(status))) @@ -1450,7 +1450,7 @@ subroutine read_depth_list(G, US, CS, filename) " Difficulties reading variable "//trim(var_msg)//& trim(NF90_STRERROR(status))) - do k=1,list_size ; CS%DL(k)%area = tmp(k) ; enddo + do k=1,list_size ; CS%DL(k)%area = US%m_to_L**2*tmp(k) ; enddo var_name = "vol_below" var_msg = trim(var_name)//" in "//trim(filename) @@ -1463,7 +1463,7 @@ subroutine read_depth_list(G, US, CS, filename) " Difficulties reading variable "//trim(var_msg)//& trim(NF90_STRERROR(status))) - do k=1,list_size ; CS%DL(k)%vol_below = US%m_to_Z*tmp(k) ; enddo + do k=1,list_size ; CS%DL(k)%vol_below = US%m_to_Z*US%m_to_L**2*tmp(k) ; enddo status = NF90_CLOSE(ncid) if (status /= NF90_NOERR) call MOM_error(WARNING, mdl// & From ed175105a954bf19d63dc64ff9c801a0f818da32 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sat, 22 Feb 2020 18:39:03 -0500 Subject: [PATCH 081/316] Rescaled the units of diabatic salt tendency Rescaled the internal calculation of the diabatic salt tendency and the boundary forcing salt tendency for code simplification and dimensional consistency testing. All answers are bitwise identical. --- .../vertical/MOM_diabatic_driver.F90 | 13 +++++++------ 1 file changed, 7 insertions(+), 6 deletions(-) diff --git a/src/parameterizations/vertical/MOM_diabatic_driver.F90 b/src/parameterizations/vertical/MOM_diabatic_driver.F90 index 022eb70f1b..8df438a7e5 100644 --- a/src/parameterizations/vertical/MOM_diabatic_driver.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_driver.F90 @@ -2977,7 +2977,7 @@ subroutine diagnose_diabatic_diff_tendency(tv, h, temp_old, saln_old, dt, G, GV, ! salt tendency 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 * ppt2mks * work_3d(i,j,k) + work_3d(i,j,k) = h(i,j,k) * ppt2mks * work_3d(i,j,k) enddo ; enddo ; enddo 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) @@ -3076,7 +3076,7 @@ subroutine diagnose_boundary_forcing_tendency(tv, h, temp_old, saln_old, h_old, ! salt tendency 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 * ppt2mks * Idt * (h(i,j,k) * tv%S(i,j,k) - h_old(i,j,k) * saln_old(i,j,k)) + work_3d(i,j,k) = 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 call post_data(CS%id_boundary_forcing_salt_tend, work_3d, CS%diag, alt_h = h_old) @@ -3550,7 +3550,7 @@ subroutine diabatic_driver_init(Time, G, GV, US, param_file, useALEalgorithm, di 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', conversion=US%s_to_T, cmor_field_name='osaltdiff', & + 'kg m-2 s-1', conversion=GV%H_to_kg_m2*US%s_to_T, 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 '// & @@ -3577,7 +3577,7 @@ subroutine diabatic_driver_init(Time, G, GV, US, param_file, useALEalgorithm, di 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', conversion=US%s_to_T, cmor_field_name='osaltdiff_2d', & + 'kg m-2 s-1', conversion=GV%H_to_kg_m2*US%s_to_T, 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 '// & @@ -3624,7 +3624,7 @@ subroutine diabatic_driver_init(Time, G, GV, US, param_file, useALEalgorithm, di CS%id_boundary_forcing_salt_tend = register_diag_field('ocean_model',& 'boundary_forcing_salt_tendency', diag%axesTL, Time, & - 'Boundary forcing salt tendency', 'kg m-2 s-1', conversion=US%s_to_T, & + 'Boundary forcing salt tendency', 'kg m-2 s-1', conversion=GV%H_to_kg_m2*US%s_to_T, & v_extensive = .true.) if (CS%id_boundary_forcing_salt_tend > 0) then CS%boundary_forcing_tendency_diag = .true. @@ -3642,7 +3642,8 @@ subroutine diabatic_driver_init(Time, G, GV, US, param_file, useALEalgorithm, di ! This diagnostic should equal to surface salt flux if all is working well. CS%id_boundary_forcing_salt_tend_2d = register_diag_field('ocean_model',& 'boundary_forcing_salt_tendency_2d', diag%axesT1, Time, & - 'Depth integrated boundary forcing of ocean salt','kg m-2 s-1', conversion=US%s_to_T) + 'Depth integrated boundary forcing of ocean salt', & + 'kg m-2 s-1', conversion=GV%H_to_kg_m2*US%s_to_T) if (CS%id_boundary_forcing_salt_tend_2d > 0) then CS%boundary_forcing_tendency_diag = .true. endif From 991bd36f225515b62f7895775315a7ba8705e38e Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sun, 23 Feb 2020 10:28:03 -0500 Subject: [PATCH 082/316] +(*)Fix ustar_gustless averaging bug Added code to optionally correct a bug in the time-averaging of the gustless wind friction velocity (ustar_gustless). This includes the addition of a new runtime parameter, FIX_USTAR_GUSTLESS_BUG, that corrects this bug when true. By default, all answers are bitwise identical. --- .../MOM_surface_forcing_gfdl.F90 | 9 +++++-- .../mct_driver/mom_surface_forcing_mct.F90 | 11 +++++--- .../mom_surface_forcing_nuopc.F90 | 11 +++++--- .../solo_driver/MOM_surface_forcing.F90 | 8 +++++- src/core/MOM_forcing_type.F90 | 26 +++++++++++++------ 5 files changed, 48 insertions(+), 17 deletions(-) diff --git a/config_src/coupled_driver/MOM_surface_forcing_gfdl.F90 b/config_src/coupled_driver/MOM_surface_forcing_gfdl.F90 index 9743c7fa3f..b8436acfac 100644 --- a/config_src/coupled_driver/MOM_surface_forcing_gfdl.F90 +++ b/config_src/coupled_driver/MOM_surface_forcing_gfdl.F90 @@ -130,6 +130,8 @@ module MOM_surface_forcing_gfdl logical :: answers_2018 !< If true, use the order of arithmetic and expressions that recover !! the answers from the end of 2018. Otherwise, use a simpler !! expression to calculate gustiness. + logical :: fix_ustar_gustless_bug !< If true correct a bug in the time-averaging of the + !! gustless wind friction velocity. logical :: check_no_land_fluxes !< Return warning if IOB flux over land is non-zero type(diag_ctrl), pointer :: diag => NULL() !< Structure to regulate diagnostic output timing @@ -274,8 +276,8 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, ! 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 allocate_forcing_type(G, fluxes, water=.true., heat=.true., ustar=.true., press=.true., & + fix_accum_bug=CS%fix_ustar_gustless_bug) call safe_alloc_ptr(fluxes%sw_vis_dir,isd,ied,jsd,jed) call safe_alloc_ptr(fluxes%sw_vis_dif,isd,ied,jsd,jed) @@ -1493,6 +1495,9 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS) "If true, use the order of arithmetic and expressions that recover the answers "//& "from the end of 2018. Otherwise, use a simpler expression to calculate gustiness.", & default=default_2018_answers) + call get_param(param_file, mdl, "FIX_USTAR_GUSTLESS_BUG", CS%fix_ustar_gustless_bug, & + "If true correct a bug in the time-averaging of the gustless wind friction velocity", & + default=.false.) ! 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, & diff --git a/config_src/mct_driver/mom_surface_forcing_mct.F90 b/config_src/mct_driver/mom_surface_forcing_mct.F90 index 981202eda8..c4e8f12464 100644 --- a/config_src/mct_driver/mom_surface_forcing_mct.F90 +++ b/config_src/mct_driver/mom_surface_forcing_mct.F90 @@ -118,6 +118,8 @@ module MOM_surface_forcing_mct 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 by basin + logical :: fix_ustar_gustless_bug !< If true correct a bug in the time-averaging of the + !! gustless wind friction velocity. 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 @@ -276,8 +278,8 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, ! 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 allocate_forcing_type(G, fluxes, water=.true., heat=.true., ustar=.true., & + press=.true., fix_accum_bug=CS%fix_ustar_gustless_bug) call safe_alloc_ptr(fluxes%sw_vis_dir,isd,ied,jsd,jed) call safe_alloc_ptr(fluxes%sw_vis_dif,isd,ied,jsd,jed) @@ -1255,9 +1257,12 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, restore_salt, call safe_alloc_ptr(CS%gust,isd,ied,jsd,jed) gust_file = trim(CS%inputdir) // trim(gust_file) - call MOM_read_data(gust_file,'gustiness',CS%gust,G%domain, timelevel=1, & + call MOM_read_data(gust_file, 'gustiness', CS%gust, G%domain, timelevel=1, & scale=US%kg_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z) ! units in file should be Pa endif + call get_param(param_file, mdl, "FIX_USTAR_GUSTLESS_BUG", CS%fix_ustar_gustless_bug, & + "If true correct a bug in the time-averaging of the gustless wind friction velocity", & + default=.false.) ! 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, & diff --git a/config_src/nuopc_driver/mom_surface_forcing_nuopc.F90 b/config_src/nuopc_driver/mom_surface_forcing_nuopc.F90 index 270d4e9f4c..83f11843c1 100644 --- a/config_src/nuopc_driver/mom_surface_forcing_nuopc.F90 +++ b/config_src/nuopc_driver/mom_surface_forcing_nuopc.F90 @@ -122,6 +122,8 @@ module MOM_surface_forcing_nuopc 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 by basin + logical :: fix_ustar_gustless_bug !< If true correct a bug in the time-averaging of the + !! gustless wind friction velocity. type(diag_ctrl), pointer :: diag !< structure to regulate diagnostic output timing character(len=200) :: inputdir !< directory where NetCDF input files are @@ -281,8 +283,8 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, ! 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 allocate_forcing_type(G, fluxes, water=.true., heat=.true., ustar=.true., & + press=.true., fix_accum_bug=CS%fix_ustar_gustless_bug) call safe_alloc_ptr(fluxes%sw_vis_dir,isd,ied,jsd,jed) call safe_alloc_ptr(fluxes%sw_vis_dif,isd,ied,jsd,jed) @@ -1249,9 +1251,12 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, restore_salt, call safe_alloc_ptr(CS%gust,isd,ied,jsd,jed) gust_file = trim(CS%inputdir) // trim(gust_file) - call MOM_read_data(gust_file,'gustiness',CS%gust,G%domain, timelevel=1, & + call MOM_read_data(gust_file, 'gustiness', CS%gust, G%domain, timelevel=1, & scale=US%kg_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z) ! units in file should be Pa endif + call get_param(param_file, mdl, "FIX_USTAR_GUSTLESS_BUG", CS%fix_ustar_gustless_bug, & + "If true correct a bug in the time-averaging of the gustless wind friction velocity", & + default=.false.) ! 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, & diff --git a/config_src/solo_driver/MOM_surface_forcing.F90 b/config_src/solo_driver/MOM_surface_forcing.F90 index a113d18871..bab6f374ab 100644 --- a/config_src/solo_driver/MOM_surface_forcing.F90 +++ b/config_src/solo_driver/MOM_surface_forcing.F90 @@ -109,6 +109,8 @@ module MOM_surface_forcing !! the answers from the end of 2018. Otherwise, use a form of the gyre !! wind stresses that are rotationally invariant and more likely to be !! the same between compilers. + logical :: fix_ustar_gustless_bug !< If true correct a bug in the time-averaging of the + !! gustless wind friction velocity. real :: T_north !< target temperatures at north used in buoyancy_forcing_linear real :: T_south !< target temperatures at south used in buoyancy_forcing_linear @@ -244,7 +246,7 @@ subroutine set_forcing(sfc_state, forces, fluxes, day_start, day_interval, G, US ! Allocate memory for the mechanical and thermodyanmic forcing fields. call allocate_mech_forcing(G, forces, stress=.true., ustar=.true., press=.true.) - call allocate_forcing_type(G, fluxes, ustar=.true.) + call allocate_forcing_type(G, fluxes, ustar=.true., fix_accum_bug=CS%fix_ustar_gustless_bug) if (trim(CS%buoy_config) /= "NONE") then if ( CS%use_temperature ) then call allocate_forcing_type(G, fluxes, water=.true., heat=.true., press=.true.) @@ -1657,6 +1659,7 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, tracer_flow_C CS%south_lat = G%south_lat CS%len_lat = G%len_lat endif + call get_param(param_file, mdl, "RHO_0", CS%Rho0, & "The mean ocean density used with BOUSSINESQ true to "//& "calculate accelerations and the mass for conservation "//& @@ -1722,6 +1725,9 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, tracer_flow_C call get_param(param_file, mdl, "GUST_CONST", CS%gust_const, & "The background gustiness in the winds.", & units="Pa", default=0.02, scale=US%kg_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z) + call get_param(param_file, mdl, "FIX_USTAR_GUSTLESS_BUG", CS%fix_ustar_gustless_bug, & + "If true correct a bug in the time-averaging of the gustless wind friction velocity", & + default=.false.) call get_param(param_file, mdl, "READ_GUST_2D", CS%read_gust_2d, & "If true, use a 2-dimensional gustiness supplied from "//& "an input file", default=.false.) diff --git a/src/core/MOM_forcing_type.F90 b/src/core/MOM_forcing_type.F90 index 3dd3af8fbf..4c04bf030b 100644 --- a/src/core/MOM_forcing_type.F90 +++ b/src/core/MOM_forcing_type.F90 @@ -164,7 +164,8 @@ module MOM_forcing_type real :: dt_buoy_accum = -1.0 !< The amount of time over which the buoyancy fluxes !! should be applied [T ~> s]. If negative, this forcing !! type variable has not yet been inialized. - + logical :: gustless_accum_bug = .true. !< If true, use an incorrect expression in the time + !! average of the gustless wind stress. real :: C_p !< heat capacity of seawater [J kg-1 degC-1]. !! C_p is is the same value as in thermovar_ptrs_type. @@ -1948,9 +1949,11 @@ subroutine fluxes_accumulate(flux_tmp, fluxes, G, wt2, forces) ! Average the water, heat, and salt fluxes, and ustar. do j=js,je ; do i=is,ie -!### Replace the expression for ustar_gustless with this one... -! fluxes%ustar_gustless(i,j) = wt1*fluxes%ustar_gustless(i,j) + wt2*flux_tmp%ustar_gustless(i,j) - fluxes%ustar_gustless(i,j) = flux_tmp%ustar_gustless(i,j) + if (fluxes%gustless_accum_bug) then + fluxes%ustar_gustless(i,j) = flux_tmp%ustar_gustless(i,j) + else + fluxes%ustar_gustless(i,j) = wt1*fluxes%ustar_gustless(i,j) + wt2*flux_tmp%ustar_gustless(i,j) + endif fluxes%evap(i,j) = wt1*fluxes%evap(i,j) + wt2*flux_tmp%evap(i,j) fluxes%lprec(i,j) = wt1*fluxes%lprec(i,j) + wt2*flux_tmp%lprec(i,j) @@ -2114,9 +2117,12 @@ subroutine set_derived_forcing_fields(forces, fluxes, G, US, Rho0) G%mask2dCv(i,J) * forces%tauy(i,J)**2) / & (G%mask2dCv(i,J-1) + G%mask2dCv(i,J)) - fluxes%ustar_gustless(i,j) = sqrt(US%L_to_Z * sqrt(taux2 + tauy2) / Rho0) -!### For efficiency this could be changed to: -! fluxes%ustar_gustless(i,j) = sqrt(sqrt(taux2 + tauy2) * Irho0) + if (fluxes%gustless_accum_bug) then + ! This change is just for computational efficiency, but it is wrapped with another change. + fluxes%ustar_gustless(i,j) = sqrt(US%L_to_Z * sqrt(taux2 + tauy2) / Rho0) + else + fluxes%ustar_gustless(i,j) = sqrt(sqrt(taux2 + tauy2) * Irho0) + endif enddo ; enddo endif @@ -2807,7 +2813,7 @@ end subroutine forcing_diagnostics !> Conditionally allocate fields within the forcing type -subroutine allocate_forcing_type(G, fluxes, water, heat, ustar, press, shelf, iceberg, salt) +subroutine allocate_forcing_type(G, fluxes, water, heat, ustar, press, shelf, iceberg, salt, fix_accum_bug) type(ocean_grid_type), intent(in) :: G !< Ocean grid structure type(forcing), intent(inout) :: fluxes !< A structure containing thermodynamic forcing fields logical, optional, intent(in) :: water !< If present and true, allocate water fluxes @@ -2817,6 +2823,8 @@ subroutine allocate_forcing_type(G, fluxes, water, heat, ustar, press, shelf, ic 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 + logical, optional, intent(in) :: fix_accum_bug !< If present and true, avoid using a bug in + !! accumulation of ustar_gustless ! Local variables integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB @@ -2872,6 +2880,8 @@ subroutine allocate_forcing_type(G, fluxes, water, heat, ustar, press, shelf, ic call myAlloc(fluxes%area_berg,isd,ied,jsd,jed, iceberg) call myAlloc(fluxes%mass_berg,isd,ied,jsd,jed, iceberg) + if (present(fix_accum_bug)) fluxes%gustless_accum_bug = .not.fix_accum_bug + end subroutine allocate_forcing_type !> Conditionally allocate fields within the mechanical forcing type From 3af944ad9d241f645a443542ad1e8584bdde2142 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Mon, 24 Feb 2020 14:07:43 -0500 Subject: [PATCH 083/316] Rearranged diagnostics to pass regression tests Rearranged scaling factors in 8 tendency diagnostics so that these diagnostics are bitwise identical to those in previous versions of the code, and so that the automated regression tests will not register a false indication of changing answers. All solutions are bitwise identical. --- .../vertical/MOM_diabatic_driver.F90 | 30 +++++++++---------- .../vertical/MOM_geothermal.F90 | 4 +-- 2 files changed, 17 insertions(+), 17 deletions(-) diff --git a/src/parameterizations/vertical/MOM_diabatic_driver.F90 b/src/parameterizations/vertical/MOM_diabatic_driver.F90 index 8df438a7e5..787482d0e2 100644 --- a/src/parameterizations/vertical/MOM_diabatic_driver.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_driver.F90 @@ -2945,7 +2945,7 @@ subroutine diagnose_diabatic_diff_tendency(tv, h, temp_old, saln_old, dt, G, GV, ! heat tendency 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) * tv%C_p * work_3d(i,j,k) + work_3d(i,j,k) = h(i,j,k)*GV%H_to_RZ * tv%C_p * work_3d(i,j,k) enddo ; enddo ; enddo 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) @@ -2977,7 +2977,7 @@ subroutine diagnose_diabatic_diff_tendency(tv, h, temp_old, saln_old, dt, G, GV, ! salt tendency 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) * ppt2mks * work_3d(i,j,k) + work_3d(i,j,k) = h(i,j,k)*GV%H_to_RZ * ppt2mks * work_3d(i,j,k) enddo ; enddo ; enddo 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) @@ -3049,7 +3049,7 @@ subroutine diagnose_boundary_forcing_tendency(tv, h, temp_old, saln_old, h_old, ! heat tendency 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) = tv%C_p * Idt * (h(i,j,k) * tv%T(i,j,k) - h_old(i,j,k) * temp_old(i,j,k)) + work_3d(i,j,k) = GV%H_to_RZ * 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 call post_data(CS%id_boundary_forcing_heat_tend, work_3d, CS%diag, alt_h = h_old) @@ -3076,7 +3076,7 @@ subroutine diagnose_boundary_forcing_tendency(tv, h, temp_old, saln_old, h_old, ! salt tendency 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) = ppt2mks * Idt * (h(i,j,k) * tv%S(i,j,k) - h_old(i,j,k) * saln_old(i,j,k)) + work_3d(i,j,k) = GV%H_to_RZ * 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 call post_data(CS%id_boundary_forcing_salt_tend, work_3d, CS%diag, alt_h = h_old) @@ -3127,7 +3127,7 @@ subroutine diagnose_frazil_tendency(tv, h, temp_old, dt, G, GV, US, CS) ! heat tendency if (CS%id_frazil_heat_tend > 0 .or. CS%id_frazil_heat_tend_2d > 0) then do k=1,nz ; do j=js,je ; do i=is,ie - CS%frazil_heat_diag(i,j,k) = tv%C_p * h(i,j,k) * Idt * (tv%T(i,j,k)-temp_old(i,j,k)) + CS%frazil_heat_diag(i,j,k) = GV%H_to_RZ * tv%C_p * h(i,j,k) * Idt * (tv%T(i,j,k)-temp_old(i,j,k)) enddo ; enddo ; enddo if (CS%id_frazil_heat_tend > 0) call post_data(CS%id_frazil_heat_tend, CS%frazil_heat_diag(:,:,:), CS%diag) @@ -3537,7 +3537,7 @@ subroutine diabatic_driver_init(Time, G, GV, US, param_file, useALEalgorithm, di CS%id_diabatic_diff_heat_tend = register_diag_field('ocean_model', & 'diabatic_heat_tendency', diag%axesTL, Time, & 'Diabatic diffusion heat tendency', & - 'W m-2', conversion=GV%H_to_RZ*US%QRZ_T_to_W_m2, cmor_field_name='opottempdiff', & + 'W m-2', conversion=US%QRZ_T_to_W_m2, 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 '// & @@ -3550,7 +3550,7 @@ subroutine diabatic_driver_init(Time, G, GV, US, param_file, useALEalgorithm, di 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', conversion=GV%H_to_kg_m2*US%s_to_T, cmor_field_name='osaltdiff', & + 'kg m-2 s-1', conversion=US%R_to_kg_m3*US%Z_to_m*US%s_to_T, 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 '// & @@ -3564,7 +3564,7 @@ subroutine diabatic_driver_init(Time, G, GV, US, param_file, useALEalgorithm, di 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', conversion=GV%H_to_RZ*US%QRZ_T_to_W_m2, cmor_field_name='opottempdiff_2d', & + 'W m-2', conversion=US%QRZ_T_to_W_m2, 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 '//& @@ -3577,7 +3577,7 @@ subroutine diabatic_driver_init(Time, G, GV, US, param_file, useALEalgorithm, di 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', conversion=GV%H_to_kg_m2*US%s_to_T, cmor_field_name='osaltdiff_2d', & + 'kg m-2 s-1', conversion=US%R_to_kg_m3*US%Z_to_m*US%s_to_T, 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 '// & @@ -3617,14 +3617,14 @@ subroutine diabatic_driver_init(Time, G, GV, US, param_file, useALEalgorithm, di CS%id_boundary_forcing_heat_tend = register_diag_field('ocean_model',& 'boundary_forcing_heat_tendency', diag%axesTL, Time, & 'Boundary forcing heat tendency', & - 'W m-2', conversion=US%QRZ_T_to_W_m2*GV%H_to_RZ, v_extensive = .true.) + 'W m-2', conversion=US%QRZ_T_to_W_m2, v_extensive = .true.) if (CS%id_boundary_forcing_heat_tend > 0) then CS%boundary_forcing_tendency_diag = .true. endif CS%id_boundary_forcing_salt_tend = register_diag_field('ocean_model',& 'boundary_forcing_salt_tendency', diag%axesTL, Time, & - 'Boundary forcing salt tendency', 'kg m-2 s-1', conversion=GV%H_to_kg_m2*US%s_to_T, & + 'Boundary forcing salt tendency', 'kg m-2 s-1', conversion=US%R_to_kg_m3*US%Z_to_m*US%s_to_T, & v_extensive = .true.) if (CS%id_boundary_forcing_salt_tend > 0) then CS%boundary_forcing_tendency_diag = .true. @@ -3634,7 +3634,7 @@ subroutine diabatic_driver_init(Time, G, GV, US, param_file, useALEalgorithm, di CS%id_boundary_forcing_heat_tend_2d = register_diag_field('ocean_model',& 'boundary_forcing_heat_tendency_2d', diag%axesT1, Time, & 'Depth integrated boundary forcing of ocean heat', & - 'W m-2', conversion=US%QRZ_T_to_W_m2*GV%H_to_RZ) + 'W m-2', conversion=US%QRZ_T_to_W_m2) if (CS%id_boundary_forcing_heat_tend_2d > 0) then CS%boundary_forcing_tendency_diag = .true. endif @@ -3643,7 +3643,7 @@ subroutine diabatic_driver_init(Time, G, GV, US, param_file, useALEalgorithm, di CS%id_boundary_forcing_salt_tend_2d = register_diag_field('ocean_model',& 'boundary_forcing_salt_tendency_2d', diag%axesT1, Time, & 'Depth integrated boundary forcing of ocean salt', & - 'kg m-2 s-1', conversion=GV%H_to_kg_m2*US%s_to_T) + 'kg m-2 s-1', conversion=US%R_to_kg_m3*US%Z_to_m*US%s_to_T) if (CS%id_boundary_forcing_salt_tend_2d > 0) then CS%boundary_forcing_tendency_diag = .true. endif @@ -3666,7 +3666,7 @@ subroutine diabatic_driver_init(Time, G, GV, US, param_file, useALEalgorithm, di CS%id_frazil_heat_tend = register_diag_field('ocean_model',& 'frazil_heat_tendency', diag%axesTL, Time, & 'Heat tendency due to frazil formation', & - 'W m-2', conversion=GV%H_to_RZ*US%QRZ_T_to_W_m2, v_extensive=.true.) + 'W m-2', conversion=US%QRZ_T_to_W_m2, v_extensive=.true.) if (CS%id_frazil_heat_tend > 0) then CS%frazil_tendency_diag = .true. endif @@ -3675,7 +3675,7 @@ subroutine diabatic_driver_init(Time, G, GV, US, param_file, useALEalgorithm, di CS%id_frazil_heat_tend_2d = register_diag_field('ocean_model',& 'frazil_heat_tendency_2d', diag%axesT1, Time, & 'Depth integrated heat tendency due to frazil formation', & - 'W m-2', conversion=GV%H_to_RZ*US%QRZ_T_to_W_m2) + 'W m-2', conversion=US%QRZ_T_to_W_m2) if (CS%id_frazil_heat_tend_2d > 0) then CS%frazil_tendency_diag = .true. endif diff --git a/src/parameterizations/vertical/MOM_geothermal.F90 b/src/parameterizations/vertical/MOM_geothermal.F90 index 638197f97c..2e2c87fcd5 100644 --- a/src/parameterizations/vertical/MOM_geothermal.F90 +++ b/src/parameterizations/vertical/MOM_geothermal.F90 @@ -337,7 +337,7 @@ subroutine geothermal(h, tv, dt, ea, eb, G, GV, US, CS, halo) ! Calculate heat tendency due to addition and transfer of internal heat if (CS%id_internal_heat_heat_tendency > 0) then - work_3d(i,j,k) = (tv%C_p * Idt) * (h(i,j,k) * tv%T(i,j,k) - h_old(i,j,k) * T_old(i,j,k)) + work_3d(i,j,k) = ((GV%H_to_RZ*tv%C_p) * Idt) * (h(i,j,k) * tv%T(i,j,k) - h_old(i,j,k) * T_old(i,j,k)) endif endif ; enddo @@ -465,7 +465,7 @@ subroutine geothermal_init(Time, G, GV, US, param_file, diag, CS) CS%id_internal_heat_heat_tendency=register_diag_field('ocean_model', & 'internal_heat_heat_tendency', diag%axesTL, Time, & 'Heat tendency (in 3D) due to internal (geothermal) sources', & - 'W m-2', conversion=GV%H_to_RZ*US%QRZ_T_to_W_m2, v_extensive=.true.) + 'W m-2', conversion=US%QRZ_T_to_W_m2, v_extensive=.true.) CS%id_internal_heat_temp_tendency=register_diag_field('ocean_model', & 'internal_heat_temp_tendency', diag%axesTL, Time, & 'Temperature tendency (in 3D) due to internal (geothermal) sources', & From 6770698642855feb089160a7b98c695b87c8eba9 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Tue, 25 Feb 2020 09:04:48 -0500 Subject: [PATCH 084/316] +Add 4 combined scaling factors to unit_scale_type Added 4 convenient combinations of units scaling factors to the unit_scale_type, to convert mass per unit area, mass fluxes, and turbulent kinetic energy fluxes. All answers are bitwise identical. --- src/framework/MOM_unit_scaling.F90 | 10 ++++++++++ 1 file changed, 10 insertions(+) diff --git a/src/framework/MOM_unit_scaling.F90 b/src/framework/MOM_unit_scaling.F90 index 63d89276a0..30e9c49850 100644 --- a/src/framework/MOM_unit_scaling.F90 +++ b/src/framework/MOM_unit_scaling.F90 @@ -33,6 +33,11 @@ module MOM_unit_scaling real :: m2_s_to_Z2_T !< Convert vertical diffusivities from m2 s-1 to Z2 T-1. real :: W_m2_to_QRZ_T !< Convert heat fluxes from W m-2 to Q R Z T-1. real :: QRZ_T_to_W_m2 !< Convert heat fluxes from Q R Z T-1 to W m-2. + ! Not used enough: real :: kg_m2_to_RZ !< Convert mass loads from kg m-2 to R Z. + real :: RZ_to_kg_m2 !< Convert mass loads from R Z to kg m-2. + real :: kg_m2s_to_RZ_T !< Convert mass fluxes from kg m-2 s-1 to R Z T-1. + real :: RZ_T_to_kg_m2s !< Convert mass fluxes from R Z T-1 to kg m-2 s-1. + real :: RZ3_T3_to_W_m2 !< Convert turbulent kinetic energy fluxes from R Z3 T-3 to W m-2. ! These are used for changing scaling across restarts. real :: m_to_Z_restart = 0.0 !< A copy of the m_to_Z that is used in restart files. @@ -130,6 +135,11 @@ subroutine unit_scaling_init( param_file, US ) ! It does not look like US%m_s2_to_L_T2 would be used, so it does not exist. US%Z2_T_to_m2_s = US%Z_to_m**2 * US%s_to_T US%m2_s_to_Z2_T = US%m_to_Z**2 * US%T_to_s + ! It does not seem like US%kg_m2_to_RZ would be used enough in MOM6 to justify its existence. + US%RZ_to_kg_m2 = US%R_to_kg_m3 * US%Z_to_m + US%kg_m2s_to_RZ_T = US%kg_m3_to_R * US%m_to_Z * US%T_to_s + US%RZ_T_to_kg_m2s = US%R_to_kg_m3 * US%Z_to_m * US%s_to_T + US%RZ3_T3_to_W_m2 = US%R_to_kg_m3 * US%Z_to_m**3 * US%s_to_T**3 US%W_m2_to_QRZ_T = US%J_kg_to_Q * US%kg_m3_to_R * US%m_to_Z * US%T_to_s US%QRZ_T_to_W_m2 = US%Q_to_J_kg * US%R_to_kg_m3 * US%Z_to_m * US%s_to_T From 9a08e703d7abfa28a320467ed22ca5d536c6e71a Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Tue, 25 Feb 2020 09:05:52 -0500 Subject: [PATCH 085/316] Use combined scaling factors Used the recently added combinations of unit scaling factors to simplify and clarify the code. Also reformatted some lines to help make it easier to see that the variable units are consistent with their scaling. All answers are bitwise identical. --- .../MOM_surface_forcing_gfdl.F90 | 18 ++-- .../ice_solo_driver/MOM_surface_forcing.F90 | 10 +-- .../mct_driver/mom_surface_forcing_mct.F90 | 16 ++-- .../mom_surface_forcing_nuopc.F90 | 18 ++-- .../solo_driver/MOM_surface_forcing.F90 | 4 +- src/core/MOM.F90 | 16 ++-- src/core/MOM_checksum_packages.F90 | 2 +- src/core/MOM_forcing_type.F90 | 36 ++++---- src/core/MOM_variables.F90 | 6 +- src/diagnostics/MOM_diagnostics.F90 | 58 ++++++------- src/diagnostics/MOM_sum_output.F90 | 4 +- src/ice_shelf/MOM_ice_shelf.F90 | 6 +- src/parameterizations/lateral/MOM_MEKE.F90 | 14 +-- .../lateral/MOM_hor_visc.F90 | 6 +- .../lateral/MOM_internal_tides.F90 | 24 +++--- .../lateral/MOM_thickness_diffuse.F90 | 2 +- .../vertical/MOM_bulk_mixed_layer.F90 | 8 +- .../vertical/MOM_diabatic_driver.F90 | 86 +++++++++---------- .../vertical/MOM_energetic_PBL.F90 | 17 ++-- .../vertical/MOM_entrain_diffusive.F90 | 4 +- .../vertical/MOM_internal_tide_input.F90 | 2 +- .../vertical/MOM_set_diffusivity.F90 | 22 ++--- .../vertical/MOM_tidal_mixing.F90 | 10 +-- .../vertical/MOM_vert_friction.F90 | 4 +- src/tracer/MOM_generic_tracer.F90 | 8 +- 25 files changed, 193 insertions(+), 208 deletions(-) diff --git a/config_src/coupled_driver/MOM_surface_forcing_gfdl.F90 b/config_src/coupled_driver/MOM_surface_forcing_gfdl.F90 index 3f3f420575..3fd9ce7888 100644 --- a/config_src/coupled_driver/MOM_surface_forcing_gfdl.F90 +++ b/config_src/coupled_driver/MOM_surface_forcing_gfdl.F90 @@ -262,7 +262,7 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, 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 - kg_m2_s_conversion = US%kg_m3_to_R*US%m_to_Z*US%T_to_s + kg_m2_s_conversion = US%kg_m2s_to_RZ_T if (CS%restore_temp) rhoXcp = CS%Rho0 * fluxes%C_p open_ocn_mask(:,:) = 1.0 pme_adj(:,:) = 0.0 @@ -370,10 +370,10 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, 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, & - unit_scale=US%R_to_kg_m3*US%Z_to_m*US%s_to_T) + unit_scale=US%RZ_T_to_kg_m2s) fluxes%saltFluxGlobalAdj = 0. else - work_sum(is:ie,js:je) = US%L_to_m**2*US%R_to_kg_m3*US%Z_to_m*US%s_to_T * & + work_sum(is:ie,js:je) = US%L_to_m**2*US%RZ_T_to_kg_m2s * & 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) - kg_m2_s_conversion * fluxes%saltFluxGlobalAdj @@ -393,11 +393,11 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, 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, & - unit_scale=US%R_to_kg_m3*US%Z_to_m*US%s_to_T) + unit_scale=US%RZ_T_to_kg_m2s) fluxes%vPrecGlobalAdj = 0. else work_sum(is:ie,js:je) = US%L_to_m**2*G%areaT(is:ie,js:je) * & - US%R_to_kg_m3*US%Z_to_m*US%s_to_T*fluxes%vprec(is:ie,js:je) + US%RZ_T_to_kg_m2s*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) - kg_m2_s_conversion*fluxes%vPrecGlobalAdj ) * G%mask2dT(i,j) @@ -589,7 +589,7 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, sign_for_net_FW_bug = 1. if (CS%use_net_FW_adjustment_sign_bug) sign_for_net_FW_bug = -1. do j=js,je ; do i=is,ie - net_FW(i,j) = US%R_to_kg_m3*US%Z_to_m*US%s_to_T* & + net_FW(i,j) = US%RZ_T_to_kg_m2s* & (((fluxes%lprec(i,j) + fluxes%fprec(i,j)) + & (fluxes%lrunoff(i,j) + fluxes%frunoff(i,j))) + & (fluxes%evap(i,j) + fluxes%vprec(i,j)) ) * US%L_to_m**2*G%areaT(i,j) @@ -608,7 +608,7 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, 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) + US%kg_m3_to_R*US%m_to_Z*US%T_to_s * & + fluxes%vprec(i,j) = fluxes%vprec(i,j) + US%kg_m2s_to_RZ_T * & (net_FW2(i,j) - net_FW(i,j)/(US%L_to_m**2*G%areaT(i,j))) * G%mask2dT(i,j) enddo ; enddo else @@ -1138,7 +1138,7 @@ subroutine apply_flux_adjustments(G, US, CS, Time, 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) + & - US%kg_m3_to_R*US%m_to_Z*US%T_to_s * temp_at_h(i,j)* G%mask2dT(i,j) + US%kg_m2s_to_RZ_T * temp_at_h(i,j)* G%mask2dT(i,j) enddo ; enddo ; endif ! Not needed? ! if (overrode_h) call pass_var(fluxes%salt_flux_added, G%Domain) @@ -1146,7 +1146,7 @@ subroutine apply_flux_adjustments(G, US, CS, Time, fluxes) call data_override('OCN', 'prcme_adj', temp_at_h(isc:iec,jsc:jec), Time, override=overrode_h) if (overrode_h) then ; do j=jsc,jec ; do i=isc,iec - fluxes%vprec(i,j) = fluxes%vprec(i,j) + US%kg_m3_to_R*US%m_to_Z*US%T_to_s * temp_at_h(i,j)* G%mask2dT(i,j) + fluxes%vprec(i,j) = fluxes%vprec(i,j) + US%kg_m2s_to_RZ_T * temp_at_h(i,j)* G%mask2dT(i,j) enddo ; enddo ; endif ! Not needed? ! if (overrode_h) call pass_var(fluxes%vprec, G%Domain) end subroutine apply_flux_adjustments diff --git a/config_src/ice_solo_driver/MOM_surface_forcing.F90 b/config_src/ice_solo_driver/MOM_surface_forcing.F90 index 4f7feb4e98..1e59fee863 100644 --- a/config_src/ice_solo_driver/MOM_surface_forcing.F90 +++ b/config_src/ice_solo_driver/MOM_surface_forcing.F90 @@ -687,7 +687,7 @@ subroutine buoyancy_forcing_from_files(sfc_state, fluxes, day, dt, G, US, CS) do j=js,je ; do i=is,ie ; fluxes%LW(i,j) = fluxes%LW(i,j) - temp(i,j) ; enddo ; enddo call MOM_read_data(trim(CS%inputdir)//trim(CS%evaporation_file), "evap", & - fluxes%evap(:,:), G%Domain, timelevel=time_lev, scale=-US%kg_m3_to_R*US%m_to_Z*US%T_to_s) + fluxes%evap(:,:), G%Domain, timelevel=time_lev, scale=-US%kg_m2s_to_RZ_T) do j=js,je ; do i=is,ie fluxes%latent(i,j) = CS%latent_heat_vapor*fluxes%evap(i,j) fluxes%latent_evap_diag(i,j) = fluxes%latent(i,j) @@ -705,20 +705,20 @@ subroutine buoyancy_forcing_from_files(sfc_state, fluxes, day, dt, G, US, CS) enddo ; enddo call MOM_read_data(trim(CS%inputdir)//trim(CS%snow_file), "snow", & - fluxes%fprec(:,:), G%Domain, timelevel=time_lev, scale=US%kg_m3_to_R*US%m_to_Z*US%T_to_s) + fluxes%fprec(:,:), G%Domain, timelevel=time_lev, scale=US%kg_m2s_to_RZ_T) call MOM_read_data(trim(CS%inputdir)//trim(CS%precip_file), "precip", & - fluxes%lprec(:,:), G%Domain, timelevel=time_lev, scale=US%kg_m3_to_R*US%m_to_Z*US%T_to_s) + fluxes%lprec(:,:), G%Domain, timelevel=time_lev, scale=US%kg_m2s_to_RZ_T) do j=js,je ; do i=is,ie fluxes%lprec(i,j) = fluxes%lprec(i,j) - fluxes%fprec(i,j) enddo ; enddo call MOM_read_data(trim(CS%inputdir)//trim(CS%freshdischarge_file), "disch_w", & - temp(:,:), G%Domain, timelevel=time_lev_monthly, scale=US%kg_m3_to_R*US%m_to_Z*US%T_to_s) + temp(:,:), G%Domain, timelevel=time_lev_monthly, scale=US%kg_m2s_to_RZ_T) do j=js,je ; do i=is,ie fluxes%lrunoff(i,j) = temp(i,j)*US%m_to_L**2*G%IareaT(i,j) enddo ; enddo call MOM_read_data(trim(CS%inputdir)//trim(CS%freshdischarge_file), "disch_s", & - temp(:,:), G%Domain, timelevel=time_lev_monthly, scale=US%kg_m3_to_R*US%m_to_Z*US%T_to_s) + temp(:,:), G%Domain, timelevel=time_lev_monthly, scale=US%kg_m2s_to_RZ_T) do j=js,je ; do i=is,ie fluxes%frunoff(i,j) = temp(i,j)*US%m_to_L**2*G%IareaT(i,j) enddo ; enddo diff --git a/config_src/mct_driver/mom_surface_forcing_mct.F90 b/config_src/mct_driver/mom_surface_forcing_mct.F90 index 1a0cdcb952..38bd54acf1 100644 --- a/config_src/mct_driver/mom_surface_forcing_mct.F90 +++ b/config_src/mct_driver/mom_surface_forcing_mct.F90 @@ -259,7 +259,7 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, 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 - kg_m2_s_conversion = US%kg_m3_to_R*US%m_to_Z*US%T_to_s + kg_m2_s_conversion = US%kg_m2s_to_RZ_T C_p = US%Q_to_J_kg*fluxes%C_p open_ocn_mask(:,:) = 1.0 pme_adj(:,:) = 0.0 @@ -372,10 +372,10 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, 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, & - unit_scale=US%R_to_kg_m3*US%Z_to_m*US%s_to_T) + unit_scale=US%RZ_T_to_kg_m2s) fluxes%saltFluxGlobalAdj = 0. else - work_sum(is:ie,js:je) = US%L_to_m**2*US%R_to_kg_m3*US%Z_to_m*US%s_to_T * & + work_sum(is:ie,js:je) = US%L_to_m**2*US%RZ_T_to_kg_m2s * & 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) - kg_m2_s_conversion * fluxes%saltFluxGlobalAdj @@ -395,11 +395,11 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, 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, & - unit_scale=US%R_to_kg_m3*US%Z_to_m*US%s_to_T) + unit_scale=US%RZ_T_to_kg_m2s) fluxes%vPrecGlobalAdj = 0. else work_sum(is:ie,js:je) = US%L_to_m**2*G%areaT(is:ie,js:je) * & - US%R_to_kg_m3*US%Z_to_m*US%s_to_T*fluxes%vprec(is:ie,js:je) + US%RZ_T_to_kg_m2s*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) - kg_m2_s_conversion*fluxes%vPrecGlobalAdj ) * G%mask2dT(i,j) @@ -551,7 +551,7 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, sign_for_net_FW_bug = 1. if (CS%use_net_FW_adjustment_sign_bug) sign_for_net_FW_bug = -1. do j=js,je ; do i=is,ie - net_FW(i,j) = US%R_to_kg_m3*US%Z_to_m*US%s_to_T * & + net_FW(i,j) = US%RZ_T_to_kg_m2s * & (((fluxes%lprec(i,j) + fluxes%fprec(i,j) + fluxes%seaice_melt(i,j)) + & (fluxes%lrunoff(i,j) + fluxes%frunoff(i,j))) + & (fluxes%evap(i,j) + fluxes%vprec(i,j)) ) * US%L_to_m**2*G%areaT(i,j) @@ -912,7 +912,7 @@ subroutine apply_flux_adjustments(G, US, CS, Time, 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) + & - US%kg_m3_to_R*US%m_to_Z*US%T_to_s * temp_at_h(i,j)* G%mask2dT(i,j) + US%kg_m2s_to_RZ_T * temp_at_h(i,j)* G%mask2dT(i,j) enddo ; enddo ; endif ! Not needed? ! if (overrode_h) call pass_var(fluxes%salt_flux_added, G%Domain) @@ -920,7 +920,7 @@ subroutine apply_flux_adjustments(G, US, CS, Time, fluxes) call data_override('OCN', 'prcme_adj', temp_at_h(isc:iec,jsc:jec), Time, override=overrode_h) if (overrode_h) then ; do j=jsc,jec ; do i=isc,iec - fluxes%vprec(i,j) = fluxes%vprec(i,j) + US%kg_m3_to_R*US%m_to_Z*US%T_to_s * temp_at_h(i,j)* G%mask2dT(i,j) + fluxes%vprec(i,j) = fluxes%vprec(i,j) + US%kg_m2s_to_RZ_T * temp_at_h(i,j)* G%mask2dT(i,j) enddo ; enddo ; endif ! Not needed? ! if (overrode_h) call pass_var(fluxes%vprec, G%Domain) diff --git a/config_src/nuopc_driver/mom_surface_forcing_nuopc.F90 b/config_src/nuopc_driver/mom_surface_forcing_nuopc.F90 index 1a1e7b9f03..ab72a830ec 100644 --- a/config_src/nuopc_driver/mom_surface_forcing_nuopc.F90 +++ b/config_src/nuopc_driver/mom_surface_forcing_nuopc.F90 @@ -264,7 +264,7 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, 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 - kg_m2_s_conversion = US%kg_m3_to_R*US%m_to_Z*US%T_to_s + kg_m2_s_conversion = US%kg_m2s_to_RZ_T C_p = US%Q_to_J_kg*fluxes%C_p open_ocn_mask(:,:) = 1.0 pme_adj(:,:) = 0.0 @@ -376,10 +376,10 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, 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, & - unit_scale=US%R_to_kg_m3*US%Z_to_m*US%s_to_T) + unit_scale=US%RZ_T_to_kg_m2s) fluxes%saltFluxGlobalAdj = 0. else - work_sum(is:ie,js:je) = US%L_to_m**2*US%R_to_kg_m3*US%Z_to_m*US%s_to_T * & + work_sum(is:ie,js:je) = US%L_to_m**2*US%RZ_T_to_kg_m2s * & 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) - kg_m2_s_conversion * fluxes%saltFluxGlobalAdj @@ -399,11 +399,11 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, 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, & - unit_scale=US%R_to_kg_m3*US%Z_to_m*US%s_to_T) + unit_scale=US%RZ_T_to_kg_m2s) fluxes%vPrecGlobalAdj = 0. else work_sum(is:ie,js:je) = US%L_to_m**2*G%areaT(is:ie,js:je) * & - US%R_to_kg_m3*US%Z_to_m*US%s_to_T*fluxes%vprec(is:ie,js:je) + US%RZ_T_to_kg_m2s*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) - kg_m2_s_conversion * fluxes%vPrecGlobalAdj ) * G%mask2dT(i,j) @@ -543,7 +543,7 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, sign_for_net_FW_bug = 1. if (CS%use_net_FW_adjustment_sign_bug) sign_for_net_FW_bug = -1. do j=js,je ; do i=is,ie - net_FW(i,j) = US%R_to_kg_m3*US%Z_to_m*US%s_to_T * & + net_FW(i,j) = US%RZ_T_to_kg_m2s * & (((fluxes%lprec(i,j) + fluxes%fprec(i,j) + fluxes%seaice_melt(i,j)) + & (fluxes%lrunoff(i,j) + fluxes%frunoff(i,j))) + & (fluxes%evap(i,j) + fluxes%vprec(i,j)) ) * US%L_to_m**2*G%areaT(i,j) @@ -553,7 +553,7 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, 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) + US%kg_m3_to_R*US%m_to_Z*US%T_to_s * & + fluxes%vprec(i,j) = fluxes%vprec(i,j) + US%kg_m2s_to_RZ_T * & (net_FW2(i,j) - net_FW(i,j)/(US%L_to_m**2*G%areaT(i,j))) * G%mask2dT(i,j) enddo ; enddo else @@ -907,7 +907,7 @@ subroutine apply_flux_adjustments(G, US, CS, Time, 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) + & - US%kg_m3_to_R*US%m_to_Z*US%T_to_s * temp_at_h(i,j)* G%mask2dT(i,j) + US%kg_m2s_to_RZ_T * temp_at_h(i,j)* G%mask2dT(i,j) enddo ; enddo ; endif ! Not needed? ! if (overrode_h) call pass_var(fluxes%salt_flux_added, G%Domain) @@ -915,7 +915,7 @@ subroutine apply_flux_adjustments(G, US, CS, Time, fluxes) call data_override('OCN', 'prcme_adj', temp_at_h(isc:iec,jsc:jec), Time, override=overrode_h) if (overrode_h) then ; do j=jsc,jec ; do i=isc,iec - fluxes%vprec(i,j) = fluxes%vprec(i,j) + US%kg_m3_to_R*US%m_to_Z*US%T_to_s * temp_at_h(i,j)* G%mask2dT(i,j) + fluxes%vprec(i,j) = fluxes%vprec(i,j) + US%kg_m2s_to_RZ_T * temp_at_h(i,j)* G%mask2dT(i,j) enddo ; enddo ; endif ! Not needed? ! if (overrode_h) call pass_var(fluxes%vprec, G%Domain) end subroutine apply_flux_adjustments diff --git a/config_src/solo_driver/MOM_surface_forcing.F90 b/config_src/solo_driver/MOM_surface_forcing.F90 index 5b49cdc662..7fded7796e 100644 --- a/config_src/solo_driver/MOM_surface_forcing.F90 +++ b/config_src/solo_driver/MOM_surface_forcing.F90 @@ -788,7 +788,7 @@ subroutine buoyancy_forcing_from_files(sfc_state, fluxes, day, dt, G, US, CS) call callTree_enter("buoyancy_forcing_from_files, MOM_surface_forcing.F90") is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec - kg_m2_s_conversion = US%kg_m3_to_R*US%m_to_Z*US%T_to_s + kg_m2_s_conversion = US%kg_m2s_to_RZ_T if (CS%use_temperature) rhoXcp = CS%Rho0 * fluxes%C_p @@ -1067,7 +1067,7 @@ subroutine buoyancy_forcing_from_data_override(sfc_state, fluxes, day, dt, G, US is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed - kg_m2_s_conversion = US%kg_m3_to_R*US%m_to_Z*US%T_to_s + kg_m2_s_conversion = US%kg_m2s_to_RZ_T if (CS%use_temperature) rhoXcp = CS%Rho0 * fluxes%C_p diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index fceec84cc9..adb916298f 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -1080,9 +1080,9 @@ subroutine step_MOM_tracer_dyn(CS, G, GV, US, h, Time_local) if (associated(CS%tv%T)) call hchksum(CS%tv%T, "Pre-advection T", G%HI, haloshift=1) if (associated(CS%tv%S)) call hchksum(CS%tv%S, "Pre-advection S", G%HI, haloshift=1) if (associated(CS%tv%frazil)) call hchksum(CS%tv%frazil, "Pre-advection frazil", G%HI, haloshift=0, & - scale=G%US%Q_to_J_kg*G%US%R_to_kg_m3*G%US%Z_to_m) + scale=G%US%Q_to_J_kg*G%US%RZ_to_kg_m2) if (associated(CS%tv%salt_deficit)) call hchksum(CS%tv%salt_deficit, & - "Pre-advection salt deficit", G%HI, haloshift=0, scale=US%R_to_kg_m3*US%Z_to_m) + "Pre-advection salt deficit", G%HI, haloshift=0, scale=US%RZ_to_kg_m2) ! call MOM_thermo_chksum("Pre-advection ", CS%tv, G, US) call cpu_clock_end(id_clock_other) endif @@ -1271,9 +1271,9 @@ subroutine step_MOM_thermo(CS, G, GV, US, u, v, h, tv, fluxes, dtdia, & if (associated(tv%T)) call hchksum(tv%T, "Post-diabatic T", G%HI, haloshift=1) if (associated(tv%S)) call hchksum(tv%S, "Post-diabatic S", G%HI, haloshift=1) if (associated(tv%frazil)) call hchksum(tv%frazil, "Post-diabatic frazil", G%HI, haloshift=0, & - scale=G%US%Q_to_J_kg*G%US%R_to_kg_m3*G%US%Z_to_m) + scale=G%US%Q_to_J_kg*G%US%RZ_to_kg_m2) if (associated(tv%salt_deficit)) call hchksum(tv%salt_deficit, & - "Post-diabatic salt deficit", G%HI, haloshift=0, scale=US%R_to_kg_m3*US%Z_to_m) + "Post-diabatic salt deficit", G%HI, haloshift=0, scale=US%RZ_to_kg_m2) ! call MOM_thermo_chksum("Post-diabatic ", tv, G, US) call check_redundant("Post-diabatic ", u, v, G) endif @@ -2775,7 +2775,7 @@ subroutine extract_surface_state(CS, sfc_state) enddo ; enddo if (allocated(sfc_state%frazil) .and. associated(CS%tv%frazil)) then ; do j=js,je ; do i=is,ie - sfc_state%frazil(i,j) = US%Q_to_J_kg*US%R_to_kg_m3*US%Z_to_m * CS%tv%frazil(i,j) + sfc_state%frazil(i,j) = US%Q_to_J_kg*US%RZ_to_kg_m2 * CS%tv%frazil(i,j) enddo ; enddo ; endif ! copy Hml into sfc_state, so that caps can access it @@ -2970,19 +2970,19 @@ subroutine extract_surface_state(CS, sfc_state) !$OMP parallel do default(shared) do j=js,je ; do i=is,ie ! Convert from gSalt to kgSalt - sfc_state%salt_deficit(i,j) = 0.001 * US%R_to_kg_m3*US%Z_to_m*CS%tv%salt_deficit(i,j) + sfc_state%salt_deficit(i,j) = 0.001 * US%RZ_to_kg_m2*CS%tv%salt_deficit(i,j) enddo ; enddo endif if (allocated(sfc_state%TempxPmE) .and. associated(CS%tv%TempxPmE)) then !$OMP parallel do default(shared) do j=js,je ; do i=is,ie - sfc_state%TempxPmE(i,j) = US%R_to_kg_m3*US%Z_to_m*CS%tv%TempxPmE(i,j) + sfc_state%TempxPmE(i,j) = US%RZ_to_kg_m2*CS%tv%TempxPmE(i,j) enddo ; enddo endif if (allocated(sfc_state%internal_heat) .and. associated(CS%tv%internal_heat)) then !$OMP parallel do default(shared) do j=js,je ; do i=is,ie - sfc_state%internal_heat(i,j) = US%R_to_kg_m3*US%Z_to_m*CS%tv%internal_heat(i,j) + sfc_state%internal_heat(i,j) = US%RZ_to_kg_m2*CS%tv%internal_heat(i,j) enddo ; enddo endif if (allocated(sfc_state%taux_shelf) .and. associated(CS%visc%taux_shelf)) then diff --git a/src/core/MOM_checksum_packages.F90 b/src/core/MOM_checksum_packages.F90 index d0df64c015..bc586e1a2f 100644 --- a/src/core/MOM_checksum_packages.F90 +++ b/src/core/MOM_checksum_packages.F90 @@ -134,7 +134,7 @@ subroutine MOM_thermo_chksum(mesg, tv, G, US, haloshift) if (associated(tv%frazil)) call hchksum(tv%frazil, mesg//" frazil", G%HI, haloshift=hs, & scale=G%US%Q_to_J_kg*G%US%R_to_kg_m3*G%US%Z_to_m) if (associated(tv%salt_deficit)) & - call hchksum(tv%salt_deficit, mesg//" salt deficit", G%HI, haloshift=hs, scale=US%R_to_kg_m3*US%Z_to_m) + call hchksum(tv%salt_deficit, mesg//" salt deficit", G%HI, haloshift=hs, scale=US%RZ_to_kg_m2) end subroutine MOM_thermo_chksum diff --git a/src/core/MOM_forcing_type.F90 b/src/core/MOM_forcing_type.F90 index 510ef58aa5..3f2ac0f1b9 100644 --- a/src/core/MOM_forcing_type.F90 +++ b/src/core/MOM_forcing_type.F90 @@ -688,7 +688,7 @@ subroutine extractFluxes1d(G, GV, US, fluxes, optics, nsw, j, dt, & ! Store Net_salt for unknown reason? if (associated(fluxes%salt_flux)) then ! This seems like a bad idea to me. -RWH - if (calculate_diags) fluxes%netSalt(i,j) = US%kg_m3_to_R*US%m_to_Z*US%T_to_s*Net_salt(i) + if (calculate_diags) fluxes%netSalt(i,j) = US%kg_m2s_to_RZ_T*Net_salt(i) endif ! Initialize heat_content_massin that is diagnosed in mixedlayer_convection or @@ -1015,7 +1015,7 @@ subroutine MOM_forcing_chksum(mesg, fluxes, G, US, haloshift) is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke hshift = 1 ; if (present(haloshift)) hshift = haloshift - RZ_T_conversion = US%R_to_kg_m3*US%Z_to_m*US%s_to_T + RZ_T_conversion = US%RZ_T_to_kg_m2s ! 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 @@ -1067,8 +1067,8 @@ subroutine MOM_forcing_chksum(mesg, fluxes, G, US, haloshift) if (associated(fluxes%salt_flux)) & call hchksum(fluxes%salt_flux, mesg//" fluxes%salt_flux",G%HI,haloshift=hshift, scale=RZ_T_conversion) if (associated(fluxes%TKE_tidal)) & - call hchksum(fluxes%TKE_tidal, mesg//" fluxes%TKE_tidal",G%HI,haloshift=hshift, & - scale=US%R_to_kg_m3**3*US%Z_to_m**3*US%s_to_T) + call hchksum(fluxes%TKE_tidal, mesg//" fluxes%TKE_tidal", G%HI, haloshift=hshift, & + scale=US%RZ3_T3_to_W_m2) if (associated(fluxes%ustar_tidal)) & call hchksum(fluxes%ustar_tidal, mesg//" fluxes%ustar_tidal",G%HI,haloshift=hshift, scale=US%Z_to_m*US%s_to_T) if (associated(fluxes%lrunoff)) & @@ -1271,7 +1271,7 @@ subroutine register_forcing_type_diags(Time, diag, US, use_temperature, handles, cmor_standard_name='sea_water_pressure_at_sea_water_surface') handles%id_TKE_tidal = register_diag_field('ocean_model', 'TKE_tidal', diag%axesT1, Time, & - 'Tidal source of BBL mixing', 'W m-2', conversion=US%R_to_kg_m3*US%Z_to_m**3*US%s_to_T**3) + 'Tidal source of BBL mixing', 'W m-2', conversion=US%RZ3_T3_to_W_m2) if (.not. use_temperature) then handles%id_buoy = register_diag_field('ocean_model', 'buoy', diag%axesT1, Time, & @@ -1291,7 +1291,7 @@ subroutine register_forcing_type_diags(Time, diag, US, use_temperature, handles, handles%id_evap = register_diag_field('ocean_model', 'evap', diag%axesT1, Time, & 'Evaporation/condensation at ocean surface (evaporation is negative)', & - 'kg m-2 s-1', conversion=US%R_to_kg_m3*US%Z_to_m*US%s_to_T, & + 'kg m-2 s-1', conversion=US%RZ_T_to_kg_m2s, & standard_name='water_evaporation_flux', cmor_field_name='evs', & cmor_standard_name='water_evaporation_flux', & cmor_long_name='Water Evaporation Flux Where Ice Free Ocean over Sea') @@ -1299,7 +1299,7 @@ subroutine register_forcing_type_diags(Time, diag, US, use_temperature, handles, ! smg: seaice_melt field requires updates to the sea ice model handles%id_seaice_melt = register_diag_field('ocean_model', 'seaice_melt', & diag%axesT1, Time, 'water flux to ocean from snow/sea ice melting(> 0) or formation(< 0)', & - 'kg m-2 s-1', conversion=US%R_to_kg_m3*US%Z_to_m*US%s_to_T, & + 'kg m-2 s-1', conversion=US%RZ_T_to_kg_m2s, & standard_name='water_flux_into_sea_water_due_to_sea_ice_thermodynamics', & cmor_field_name='fsitherm', & cmor_standard_name='water_flux_into_sea_water_due_to_sea_ice_thermodynamics',& @@ -1311,24 +1311,24 @@ subroutine register_forcing_type_diags(Time, diag, US, use_temperature, handles, handles%id_fprec = register_diag_field('ocean_model', 'fprec', diag%axesT1, Time, & 'Frozen precipitation into ocean', & - units='kg m-2 s-1', conversion=US%R_to_kg_m3*US%Z_to_m*US%s_to_T, & + units='kg m-2 s-1', conversion=US%RZ_T_to_kg_m2s, & standard_name='snowfall_flux', cmor_field_name='prsn', & cmor_standard_name='snowfall_flux', cmor_long_name='Snowfall Flux where Ice Free Ocean over Sea') handles%id_lprec = register_diag_field('ocean_model', 'lprec', diag%axesT1, Time, & 'Liquid precipitation into ocean', & - units='kg m-2 s-1', conversion=US%R_to_kg_m3*US%Z_to_m*US%s_to_T, & + units='kg m-2 s-1', conversion=US%RZ_T_to_kg_m2s, & standard_name='rainfall_flux', & cmor_field_name='prlq', cmor_standard_name='rainfall_flux', & cmor_long_name='Rainfall Flux where Ice Free Ocean over Sea') handles%id_vprec = register_diag_field('ocean_model', 'vprec', diag%axesT1, Time, & 'Virtual liquid precip into ocean due to SSS restoring', & - units='kg m-2 s-1', conversion=US%R_to_kg_m3*US%Z_to_m*US%s_to_T) + units='kg m-2 s-1', conversion=US%RZ_T_to_kg_m2s) handles%id_frunoff = register_diag_field('ocean_model', 'frunoff', diag%axesT1, Time, & 'Frozen runoff (calving) and iceberg melt into ocean', & - units='kg m-2 s-1', conversion=US%R_to_kg_m3*US%Z_to_m*US%s_to_T, & + units='kg m-2 s-1', conversion=US%RZ_T_to_kg_m2s, & standard_name='water_flux_into_sea_water_from_icebergs', & cmor_field_name='ficeberg', & cmor_standard_name='water_flux_into_sea_water_from_icebergs', & @@ -1336,7 +1336,7 @@ subroutine register_forcing_type_diags(Time, diag, US, use_temperature, handles, handles%id_lrunoff = register_diag_field('ocean_model', 'lrunoff', diag%axesT1, Time, & 'Liquid runoff (rivers) into ocean', & - units='kg m-2 s-1', conversion=US%R_to_kg_m3*US%Z_to_m*US%s_to_T, & + units='kg m-2 s-1', conversion=US%RZ_T_to_kg_m2s, & standard_name='water_flux_into_sea_water_from_rivers', cmor_field_name='friver', & cmor_standard_name='water_flux_into_sea_water_from_rivers', & cmor_long_name='Water Flux into Sea Water From Rivers') @@ -1813,22 +1813,22 @@ subroutine register_forcing_type_diags(Time, diag, US, use_temperature, handles, handles%id_saltflux = register_diag_field('ocean_model', 'salt_flux', diag%axesT1, Time,& 'Net salt flux into ocean at surface (restoring + sea-ice)', & - units='kg m-2 s-1', conversion=US%R_to_kg_m3*US%Z_to_m*US%s_to_T, & + units='kg m-2 s-1', conversion=US%RZ_T_to_kg_m2s, & cmor_field_name='sfdsi', cmor_standard_name='downward_sea_ice_basal_salt_flux', & cmor_long_name='Downward Sea Ice Basal Salt Flux') handles%id_saltFluxIn = register_diag_field('ocean_model', 'salt_flux_in', diag%axesT1, Time, & 'Salt flux into ocean at surface from coupler', & - units='kg m-2 s-1', conversion=US%R_to_kg_m3*US%Z_to_m*US%s_to_T) + units='kg m-2 s-1', conversion=US%RZ_T_to_kg_m2s) handles%id_saltFluxAdded = register_diag_field('ocean_model', 'salt_flux_added', & diag%axesT1,Time,'Salt flux into ocean at surface due to restoring or flux adjustment', & - units='kg m-2 s-1', conversion=US%R_to_kg_m3*US%Z_to_m*US%s_to_T) + units='kg m-2 s-1', conversion=US%RZ_T_to_kg_m2s) handles%id_saltFluxGlobalAdj = register_scalar_field('ocean_model', & 'salt_flux_global_restoring_adjustment', Time, diag, & 'Adjustment needed to balance net global salt flux into ocean at surface', & - units='kg m-2 s-1') !, conversion=US%R_to_kg_m3*US%Z_to_m*US%s_to_T) + units='kg m-2 s-1') !, conversion=US%RZ_T_to_kg_m2s) handles%id_vPrecGlobalAdj = register_scalar_field('ocean_model', & 'vprec_global_adjustment', Time, diag, & @@ -2153,7 +2153,7 @@ subroutine get_net_mass_forcing(fluxes, G, US, net_mass_src) integer :: i, j, is, ie, js, je is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec - RZ_T_conversion = US%R_to_kg_m3*US%Z_to_m*US%s_to_T + RZ_T_conversion = US%RZ_T_to_kg_m2s net_mass_src(:,:) = 0.0 if (associated(fluxes%lprec)) then ; do j=js,je ; do i=is,ie @@ -2261,7 +2261,7 @@ subroutine forcing_diagnostics(fluxes, sfc_state, G, US, time_end, diag, handles call cpu_clock_begin(handles%id_clock_forcing) C_p = US%Q_to_J_kg*fluxes%C_p - RZ_T_conversion = US%R_to_kg_m3*US%Z_to_m*US%s_to_T + RZ_T_conversion = US%RZ_T_to_kg_m2s I_dt = 1.0 / (US%T_to_s*fluxes%dt_buoy_accum) ppt2mks = 1e-3 is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec diff --git a/src/core/MOM_variables.F90 b/src/core/MOM_variables.F90 index 93fffb3c51..94cf169e29 100644 --- a/src/core/MOM_variables.F90 +++ b/src/core/MOM_variables.F90 @@ -466,11 +466,11 @@ subroutine MOM_thermovar_chksum(mesg, tv, G) if (associated(tv%S)) & call hchksum(tv%S, mesg//" tv%S", G%HI) if (associated(tv%frazil)) & - call hchksum(tv%frazil, mesg//" tv%frazil", G%HI, scale=G%US%Q_to_J_kg*G%US%R_to_kg_m3*G%US%Z_to_m) + call hchksum(tv%frazil, mesg//" tv%frazil", G%HI, scale=G%US%Q_to_J_kg*G%US%RZ_to_kg_m2) if (associated(tv%salt_deficit)) & - call hchksum(tv%salt_deficit, mesg//" tv%salt_deficit", G%HI, scale=G%US%R_to_kg_m3*G%US%Z_to_m) + call hchksum(tv%salt_deficit, mesg//" tv%salt_deficit", G%HI, scale=G%US%RZ_to_kg_m2) if (associated(tv%TempxPmE)) & - call hchksum(tv%TempxPmE, mesg//" tv%TempxPmE", G%HI, scale=G%US%R_to_kg_m3*G%US%Z_to_m) + call hchksum(tv%TempxPmE, mesg//" tv%TempxPmE", G%HI, scale=G%US%RZ_to_kg_m2) end subroutine MOM_thermovar_chksum end module MOM_variables diff --git a/src/diagnostics/MOM_diagnostics.F90 b/src/diagnostics/MOM_diagnostics.F90 index 17996d785a..09a51fac3c 100644 --- a/src/diagnostics/MOM_diagnostics.F90 +++ b/src/diagnostics/MOM_diagnostics.F90 @@ -1604,18 +1604,18 @@ subroutine MOM_diagnostics_init(MIS, ADp, CDp, Time, G, GV, US, param_file, diag ! layer thickness variables !if (GV%nk_rho_varies > 0) then CS%id_h_Rlay = register_diag_field('ocean_model', 'h_rho', diag%axesTL, Time, & - 'Layer thicknesses in pure potential density coordinates', thickness_units, & - conversion=convert_H) + 'Layer thicknesses in pure potential density coordinates', & + thickness_units, conversion=convert_H) if (CS%id_h_Rlay>0) call safe_alloc_ptr(CS%h_Rlay,isd,ied,jsd,jed,nz) CS%id_uh_Rlay = register_diag_field('ocean_model', 'uh_rho', diag%axesCuL, Time, & - 'Zonal volume transport in pure potential density coordinates', flux_units, & - conversion=US%L_to_m**2*US%s_to_T*convert_H) + 'Zonal volume transport in pure potential density coordinates', & + flux_units, conversion=US%L_to_m**2*US%s_to_T*convert_H) if (CS%id_uh_Rlay>0) call safe_alloc_ptr(CS%uh_Rlay,IsdB,IedB,jsd,jed,nz) CS%id_vh_Rlay = register_diag_field('ocean_model', 'vh_rho', diag%axesCvL, Time, & - 'Meridional volume transport in pure potential density coordinates', flux_units, & - conversion=US%L_to_m**2*US%s_to_T*convert_H) + 'Meridional volume transport in pure potential density coordinates', & + flux_units, conversion=US%L_to_m**2*US%s_to_T*convert_H) if (CS%id_vh_Rlay>0) call safe_alloc_ptr(CS%vh_Rlay,isd,ied,JsdB,JedB,nz) CS%id_uhGM_Rlay = register_diag_field('ocean_model', 'uhGM_rho', diag%axesCuL, Time, & @@ -1632,44 +1632,44 @@ subroutine MOM_diagnostics_init(MIS, ADp, CDp, Time, G, GV, US, param_file, diag ! terms in the kinetic energy budget CS%id_KE = register_diag_field('ocean_model', 'KE', diag%axesTL, Time, & - 'Layer kinetic energy per unit mass', 'm2 s-2', & - conversion=US%L_T_to_m_s**2) + 'Layer kinetic energy per unit mass', & + 'm2 s-2', conversion=US%L_T_to_m_s**2) if (CS%id_KE>0) call safe_alloc_ptr(CS%KE,isd,ied,jsd,jed,nz) CS%id_dKEdt = register_diag_field('ocean_model', 'dKE_dt', diag%axesTL, Time, & - 'Kinetic Energy Tendency of Layer', 'm3 s-3', & - conversion=GV%H_to_m*(US%L_T_to_m_s**2)*US%s_to_T) + 'Kinetic Energy Tendency of Layer', & + 'm3 s-3', conversion=GV%H_to_m*(US%L_T_to_m_s**2)*US%s_to_T) if (CS%id_dKEdt>0) call safe_alloc_ptr(CS%dKE_dt,isd,ied,jsd,jed,nz) CS%id_PE_to_KE = register_diag_field('ocean_model', 'PE_to_KE', diag%axesTL, Time, & - 'Potential to Kinetic Energy Conversion of Layer', 'm3 s-3', & - conversion=GV%H_to_m*(US%L_T_to_m_s**2)*US%s_to_T) + 'Potential to Kinetic Energy Conversion of Layer', & + 'm3 s-3', conversion=GV%H_to_m*(US%L_T_to_m_s**2)*US%s_to_T) if (CS%id_PE_to_KE>0) call safe_alloc_ptr(CS%PE_to_KE,isd,ied,jsd,jed,nz) CS%id_KE_Coradv = register_diag_field('ocean_model', 'KE_Coradv', diag%axesTL, Time, & - 'Kinetic Energy Source from Coriolis and Advection', 'm3 s-3', & - conversion=GV%H_to_m*(US%L_T_to_m_s**2)*US%s_to_T) + 'Kinetic Energy Source from Coriolis and Advection', & + 'm3 s-3', conversion=GV%H_to_m*(US%L_T_to_m_s**2)*US%s_to_T) if (CS%id_KE_Coradv>0) call safe_alloc_ptr(CS%KE_Coradv,isd,ied,jsd,jed,nz) CS%id_KE_adv = register_diag_field('ocean_model', 'KE_adv', diag%axesTL, Time, & - 'Kinetic Energy Source from Advection', 'm3 s-3', & - conversion=GV%H_to_m*(US%L_T_to_m_s**2)*US%s_to_T) + 'Kinetic Energy Source from Advection', & + 'm3 s-3', conversion=GV%H_to_m*(US%L_T_to_m_s**2)*US%s_to_T) if (CS%id_KE_adv>0) call safe_alloc_ptr(CS%KE_adv,isd,ied,jsd,jed,nz) CS%id_KE_visc = register_diag_field('ocean_model', 'KE_visc', diag%axesTL, Time, & - 'Kinetic Energy Source from Vertical Viscosity and Stresses', 'm3 s-3', & - conversion=GV%H_to_m*(US%L_T_to_m_s**2)*US%s_to_T) + 'Kinetic Energy Source from Vertical Viscosity and Stresses', & + 'm3 s-3', conversion=GV%H_to_m*(US%L_T_to_m_s**2)*US%s_to_T) if (CS%id_KE_visc>0) call safe_alloc_ptr(CS%KE_visc,isd,ied,jsd,jed,nz) CS%id_KE_horvisc = register_diag_field('ocean_model', 'KE_horvisc', diag%axesTL, Time, & - 'Kinetic Energy Source from Horizontal Viscosity', 'm3 s-3', & - conversion=GV%H_to_m*(US%L_T_to_m_s**2)*US%s_to_T) + 'Kinetic Energy Source from Horizontal Viscosity', & + 'm3 s-3', conversion=GV%H_to_m*(US%L_T_to_m_s**2)*US%s_to_T) if (CS%id_KE_horvisc>0) call safe_alloc_ptr(CS%KE_horvisc,isd,ied,jsd,jed,nz) if (.not. adiabatic) then CS%id_KE_dia = register_diag_field('ocean_model', 'KE_dia', diag%axesTL, Time, & - 'Kinetic Energy Source from Diapycnal Diffusion', 'm3 s-3', & - conversion=GV%H_to_m*(US%L_T_to_m_s**2)*US%s_to_T) + 'Kinetic Energy Source from Diapycnal Diffusion', & + 'm3 s-3', conversion=GV%H_to_m*(US%L_T_to_m_s**2)*US%s_to_T) if (CS%id_KE_dia>0) call safe_alloc_ptr(CS%KE_dia,isd,ied,jsd,jed,nz) endif @@ -1802,7 +1802,7 @@ subroutine register_surface_diags(Time, G, US, IDs, diag, tv) IDs%id_salt_deficit = register_diag_field('ocean_model', 'salt_deficit', diag%axesT1, Time, & 'Salt sink in ocean due to ice flux', & - 'psu m-2 s-1', conversion=US%R_to_kg_m3*US%Z_to_m*US%s_to_T) + 'psu m-2 s-1', conversion=US%RZ_T_to_kg_m2s) IDs%id_Heat_PmE = register_diag_field('ocean_model', 'Heat_PmE', diag%axesT1, Time, & 'Heat flux into ocean from mass flux into ocean', & 'W m-2', conversion=US%QRZ_T_to_W_m2) @@ -1935,12 +1935,11 @@ subroutine write_static_fields(G, GV, US, tv, diag) if (id > 0) call post_data(id, G%areaBu, diag, .true.) id = register_static_field('ocean_model', 'depth_ocean', diag%axesT1, & - 'Depth of the ocean at tracer points', 'm', & + 'Depth of the ocean at tracer points', 'm', conversion=US%Z_to_m, & standard_name='sea_floor_depth_below_geoid', & cmor_field_name='deptho', cmor_long_name='Sea Floor Depth', & cmor_standard_name='sea_floor_depth_below_geoid', area=diag%axesT1%id_area, & - x_cell_method='mean', y_cell_method='mean', area_cell_method='mean', & - conversion=US%Z_to_m) + x_cell_method='mean', y_cell_method='mean', area_cell_method='mean') if (id > 0) call post_data(id, G%bathyT, diag, .true., mask=G%mask2dT) id = register_static_field('ocean_model', 'wet', diag%axesT1, & @@ -2007,17 +2006,16 @@ subroutine write_static_fields(G, GV, US, tv, diag) ! This static diagnostic is from CF 1.8, and is the fraction of a cell ! covered by ocean, given as a percentage (poorly named). id = register_static_field('ocean_model', 'area_t_percent', diag%axesT1, & - 'Percentage of cell area covered by ocean', '%', & + 'Percentage of cell area covered by ocean', '%', conversion=100.0, & cmor_field_name='sftof', cmor_standard_name='SeaAreaFraction', & cmor_long_name='Sea Area Fraction', & - x_cell_method='mean', y_cell_method='mean', area_cell_method='mean', & - conversion=100.0) + x_cell_method='mean', y_cell_method='mean', area_cell_method='mean') if (id > 0) call post_data(id, G%mask2dT, diag, .true.) id = register_static_field('ocean_model','Rho_0', diag%axesNull, & 'mean ocean density used with the Boussinesq approximation', & - 'kg m-3', cmor_field_name='rhozero', conversion=US%R_to_kg_m3, & + 'kg m-3', conversion=US%R_to_kg_m3, cmor_field_name='rhozero', & cmor_standard_name='reference_sea_water_density_for_boussinesq_approximation', & cmor_long_name='reference sea water density for boussinesq approximation') if (id > 0) call post_data(id, GV%Rho0, diag, .true.) diff --git a/src/diagnostics/MOM_sum_output.F90 b/src/diagnostics/MOM_sum_output.F90 index 6a0334e3ac..c7c8d81019 100644 --- a/src/diagnostics/MOM_sum_output.F90 +++ b/src/diagnostics/MOM_sum_output.F90 @@ -660,7 +660,7 @@ subroutine write_energy(u, v, h, tv, day, n, G, GV, US, CS, tracer_CSp, OBC, dt_ ! Calculate the Available Potential Energy integrated over each interface. With a nonlinear ! equation of state or with a bulk mixed layer this calculation is only approximate. ! With an ALE model this does not make sense and should be revisited. - PE_scale_factor = US%Z_to_m*US%L_to_m**2*US%L_T_to_m_s**2*US%R_to_kg_m3 + PE_scale_factor = US%RZ_to_kg_m2*US%L_to_m**2*US%L_T_to_m_s**2 PE_pt(:,:,:) = 0.0 if (GV%Boussinesq) then do j=js,je ; do i=is,ie @@ -978,7 +978,7 @@ subroutine accumulate_net_input(fluxes, sfc_state, tv, dt, G, US, CS) is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec - RZL2_to_kg = US%L_to_m**2*US%R_to_kg_m3*US%Z_to_m + RZL2_to_kg = US%L_to_m**2*US%RZ_to_kg_m2 QRZL2_to_J = RZL2_to_kg*US%Q_to_J_kg FW_in(:,:) = 0.0 ; FW_input = 0.0 diff --git a/src/ice_shelf/MOM_ice_shelf.F90 b/src/ice_shelf/MOM_ice_shelf.F90 index 50282a319b..a0f54efb2d 100644 --- a/src/ice_shelf/MOM_ice_shelf.F90 +++ b/src/ice_shelf/MOM_ice_shelf.F90 @@ -967,10 +967,10 @@ subroutine add_shelf_flux(G, US, CS, state, fluxes) 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) = US%kg_m3_to_R*US%m_to_Z*US%T_to_s*frac_area*ISS%water_flux(i,j)*CS%flux_factor + fluxes%lprec(i,j) = US%kg_m2s_to_RZ_T*frac_area*ISS%water_flux(i,j)*CS%flux_factor else fluxes%lprec(i,j) = 0.0 - fluxes%evap(i,j) = US%kg_m3_to_R*US%m_to_Z*US%T_to_s*frac_area*ISS%water_flux(i,j)*CS%flux_factor + fluxes%evap(i,j) = US%kg_m2s_to_RZ_T*frac_area*ISS%water_flux(i,j)*CS%flux_factor endif endif @@ -1060,7 +1060,7 @@ subroutine add_shelf_flux(G, US, CS, state, fluxes) 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 ! Rescale fluxes%vprec to the proper units. - fluxes%vprec(i,j) = US%kg_m3_to_R*US%m_to_Z*US%T_to_s * fluxes%vprec(i,j) + fluxes%vprec(i,j) = US%kg_m2s_to_RZ_T * fluxes%vprec(i,j) fluxes%sens(i,j) = fluxes%vprec(i,j) * US%J_kg_to_Q*CS%Cp * CS%T0 ! [ Q R Z T-1 ~> W /m^2 ] fluxes%salt_flux(i,j) = fluxes%vprec(i,j) * CS%S0*1.0e-3 ! kg (salt)/(m^2 s) endif diff --git a/src/parameterizations/lateral/MOM_MEKE.F90 b/src/parameterizations/lateral/MOM_MEKE.F90 index a2257369a8..f8ee166a03 100644 --- a/src/parameterizations/lateral/MOM_MEKE.F90 +++ b/src/parameterizations/lateral/MOM_MEKE.F90 @@ -181,11 +181,11 @@ subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt, G, GV, US, CS, hu, h if (CS%debug) then if (associated(MEKE%mom_src)) & - call hchksum(MEKE%mom_src, 'MEKE mom_src', G%HI, scale=US%R_to_kg_m3*US%Z_to_m*US%L_to_m**2*US%s_to_T**3) + call hchksum(MEKE%mom_src, 'MEKE mom_src', G%HI, scale=US%RZ3_T3_to_W_m2*US%L_to_Z**2) if (associated(MEKE%GME_snk)) & - call hchksum(MEKE%GME_snk, 'MEKE GME_snk', G%HI, scale=US%R_to_kg_m3*US%Z_to_m*US%L_to_m**2*US%s_to_T**3) + call hchksum(MEKE%GME_snk, 'MEKE GME_snk', G%HI, scale=US%RZ3_T3_to_W_m2*US%L_to_Z**2) if (associated(MEKE%GM_src)) & - call hchksum(MEKE%GM_src, 'MEKE GM_src', G%HI, scale=US%R_to_kg_m3*US%Z_to_m*US%L_to_m**2*US%s_to_T**3) + call hchksum(MEKE%GM_src, 'MEKE GM_src', G%HI, scale=US%RZ3_T3_to_W_m2*US%L_to_Z**2) if (associated(MEKE%MEKE)) call hchksum(MEKE%MEKE, 'MEKE MEKE', G%HI, scale=US%L_T_to_m_s**2) call uvchksum("MEKE SN_[uv]", SN_u, SN_v, G%HI, scale=US%s_to_T) call uvchksum("MEKE h[uv]", hu, hv, G%HI, haloshift=1, scale=GV%H_to_m*US%L_to_m**2) @@ -278,7 +278,7 @@ subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt, G, GV, US, CS, hu, h call MEKE_lengthScales(CS, MEKE, G, GV, US, SN_u, SN_v, MEKE%MEKE, bottomFac2, barotrFac2, LmixScale) if (CS%debug) then call uvchksum("MEKE drag_vel_[uv]", drag_vel_u, drag_vel_v, G%HI, scale=US%Z_to_m*US%s_to_T) - call hchksum(mass, 'MEKE mass',G%HI,haloshift=1, scale=US%R_to_kg_m3*US%Z_to_m) + call hchksum(mass, 'MEKE mass',G%HI,haloshift=1, scale=US%RZ_to_kg_m2) call hchksum(drag_rate_visc, 'MEKE drag_rate_visc', G%HI, scale=US%L_T_to_m_s) call hchksum(bottomFac2, 'MEKE bottomFac2', G%HI) call hchksum(barotrFac2, 'MEKE barotrFac2', G%HI) @@ -1170,15 +1170,15 @@ logical function MEKE_init(Time, G, US, param_file, diag, CS, MEKE, restart_CS) 'MEKE decay rate', 's-1', conversion=US%s_to_T) CS%id_GM_src = register_diag_field('ocean_model', 'MEKE_GM_src', diag%axesT1, Time, & 'MEKE energy available from thickness mixing', & - 'W m-2', conversion=US%R_to_kg_m3*US%Z_to_m*US%L_to_m**2*US%s_to_T**3) + 'W m-2', conversion=US%RZ3_T3_to_W_m2*US%L_to_Z**2) if (.not. associated(MEKE%GM_src)) CS%id_GM_src = -1 CS%id_mom_src = register_diag_field('ocean_model', 'MEKE_mom_src',diag%axesT1, Time, & 'MEKE energy available from momentum', & - 'W m-2', conversion=US%R_to_kg_m3*US%Z_to_m*US%L_to_m**2*US%s_to_T**3) + 'W m-2', conversion=US%RZ3_T3_to_W_m2*US%L_to_Z**2) if (.not. associated(MEKE%mom_src)) CS%id_mom_src = -1 CS%id_GME_snk = register_diag_field('ocean_model', 'MEKE_GME_snk',diag%axesT1, Time, & 'MEKE energy lost to GME backscatter', & - 'W m-2', conversion=US%R_to_kg_m3*US%Z_to_m*US%L_to_m**2*US%s_to_T**3) + 'W m-2', conversion=US%RZ3_T3_to_W_m2*US%L_to_Z**2) if (.not. associated(MEKE%GME_snk)) CS%id_GME_snk = -1 CS%id_Le = register_diag_field('ocean_model', 'MEKE_Le', diag%axesT1, Time, & 'Eddy mixing length used in the MEKE derived eddy diffusivity', 'm', conversion=US%L_to_m) diff --git a/src/parameterizations/lateral/MOM_hor_visc.F90 b/src/parameterizations/lateral/MOM_hor_visc.F90 index 0298bac5ab..c818603366 100644 --- a/src/parameterizations/lateral/MOM_hor_visc.F90 +++ b/src/parameterizations/lateral/MOM_hor_visc.F90 @@ -2107,16 +2107,16 @@ subroutine hor_visc_init(Time, G, US, param_file, diag, CS, MEKE) CS%id_FrictWork_GME = register_diag_field('ocean_model','FrictWork_GME',diag%axesTL,Time,& 'Integral work done by lateral friction terms in GME (excluding diffusion of energy)', & - 'W m-2', conversion=US%R_to_kg_m3*US%Z_to_m*US%s_to_T**3*US%L_to_m**2) + 'W m-2', conversion=US%RZ3_T3_to_W_m2*US%L_to_Z**2) endif CS%id_FrictWork = register_diag_field('ocean_model','FrictWork',diag%axesTL,Time,& 'Integral work done by lateral friction terms', & - 'W m-2', conversion=US%R_to_kg_m3*US%Z_to_m*US%s_to_T**3*US%L_to_m**2) + 'W m-2', conversion=US%RZ3_T3_to_W_m2*US%L_to_Z**2) CS%id_FrictWorkIntz = register_diag_field('ocean_model','FrictWorkIntz',diag%axesT1,Time, & 'Depth integrated work done by lateral friction', & - 'W m-2', conversion=US%R_to_kg_m3*US%Z_to_m*US%s_to_T**3*US%L_to_m**2, & + 'W m-2', conversion=US%RZ3_T3_to_W_m2*US%L_to_Z**2, & cmor_field_name='dispkexyfo', & cmor_long_name='Depth integrated ocean kinetic energy dissipation due to lateral friction',& cmor_standard_name='ocean_kinetic_energy_dissipation_per_unit_area_due_to_xy_friction') diff --git a/src/parameterizations/lateral/MOM_internal_tides.F90 b/src/parameterizations/lateral/MOM_internal_tides.F90 index d9e77f2180..efa82206a4 100644 --- a/src/parameterizations/lateral/MOM_internal_tides.F90 +++ b/src/parameterizations/lateral/MOM_internal_tides.F90 @@ -2427,7 +2427,7 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) ! Register 2-D energy density (summed over angles, freq, modes) CS%id_tot_En = register_diag_field('ocean_model', 'ITide_tot_En', diag%axesT1, & Time, 'Internal tide total energy density', & - 'J m-2', conversion=US%R_to_kg_m3*US%Z_to_m**3*US%s_to_T**2) + 'J m-2', conversion=US%RZ3_T3_to_W_m2*US%T_to_s) ! Register 2-D drag scale used for quadratic bottom drag CS%id_itide_drag = register_diag_field('ocean_model', 'ITide_drag', diag%axesT1, & Time, 'Interior and bottom drag internal tide decay timescale', 's-1', conversion=US%s_to_T) @@ -2435,23 +2435,23 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) CS%id_TKE_itidal_input = register_diag_field('ocean_model', 'TKE_itidal_input', diag%axesT1, & Time, 'Conversion from barotropic to baroclinic tide, '//& 'a fraction of which goes into rays', & - 'W m-2', conversion=US%R_to_kg_m3*US%Z_to_m**3*US%s_to_T**3) + 'W m-2', conversion=US%RZ3_T3_to_W_m2) ! Register 2-D energy losses (summed over angles, freq, modes) CS%id_tot_leak_loss = register_diag_field('ocean_model', 'ITide_tot_leak_loss', diag%axesT1, & Time, 'Internal tide energy loss to background drag', & - 'W m-2', conversion=US%R_to_kg_m3*US%Z_to_m**3*US%s_to_T**3) + 'W m-2', conversion=US%RZ3_T3_to_W_m2) CS%id_tot_quad_loss = register_diag_field('ocean_model', 'ITide_tot_quad_loss', diag%axesT1, & Time, 'Internal tide energy loss to bottom drag', & - 'W m-2', conversion=US%R_to_kg_m3*US%Z_to_m**3*US%s_to_T**3) + 'W m-2', conversion=US%RZ3_T3_to_W_m2) CS%id_tot_itidal_loss = register_diag_field('ocean_model', 'ITide_tot_itidal_loss', diag%axesT1, & Time, 'Internal tide energy loss to wave drag', & - 'W m-2', conversion=US%R_to_kg_m3*US%Z_to_m**3*US%s_to_T**3) + 'W m-2', conversion=US%RZ3_T3_to_W_m2) CS%id_tot_Froude_loss = register_diag_field('ocean_model', 'ITide_tot_Froude_loss', diag%axesT1, & Time, 'Internal tide energy loss to wave breaking', & - 'W m-2', conversion=US%R_to_kg_m3*US%Z_to_m**3*US%s_to_T**3) + 'W m-2', conversion=US%RZ3_T3_to_W_m2) CS%id_tot_allprocesses_loss = register_diag_field('ocean_model', 'ITide_tot_allprocesses_loss', diag%axesT1, & Time, 'Internal tide energy loss summed over all processes', & - 'W m-2', conversion=US%R_to_kg_m3*US%Z_to_m**3*US%s_to_T**3) + 'W m-2', conversion=US%RZ3_T3_to_W_m2) allocate(CS%id_En_mode(CS%nFreq,CS%nMode)) ; CS%id_En_mode(:,:) = -1 allocate(CS%id_En_ang_mode(CS%nFreq,CS%nMode)) ; CS%id_En_ang_mode(:,:) = -1 @@ -2474,14 +2474,14 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) write(var_name, '("Itide_En_freq",i1,"_mode",i1)') fr, m write(var_descript, '("Internal tide energy density in frequency ",i1," mode ",i1)') fr, m CS%id_En_mode(fr,m) = register_diag_field('ocean_model', var_name, & - diag%axesT1, Time, var_descript, 'J m-2', conversion=US%R_to_kg_m3*US%Z_to_m**2*US%s_to_T**3) + diag%axesT1, Time, var_descript, 'J m-2', conversion=US%RZ3_T3_to_W_m2*US%T_to_s) call MOM_mesg("Registering "//trim(var_name)//", Described as: "//var_descript, 5) ! Register 3-D (i,j,a) energy density for each freq and mode write(var_name, '("Itide_En_ang_freq",i1,"_mode",i1)') fr, m write(var_descript, '("Internal tide angular energy density in frequency ",i1," mode ",i1)') fr, m CS%id_En_ang_mode(fr,m) = register_diag_field('ocean_model', var_name, & - axes_ang, Time, var_descript, 'J m-2 band-1', conversion=US%R_to_kg_m3*US%Z_to_m**2*US%s_to_T**3) + axes_ang, Time, var_descript, 'J m-2 band-1', conversion=US%RZ3_T3_to_W_m2*US%T_to_s) call MOM_mesg("Registering "//trim(var_name)//", Described as: "//var_descript, 5) ! Register 2-D energy loss (summed over angles) for each freq and mode @@ -2489,13 +2489,13 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) write(var_name, '("Itide_wavedrag_loss_freq",i1,"_mode",i1)') fr, m write(var_descript, '("Internal tide energy loss due to wave-drag from frequency ",i1," mode ",i1)') fr, m CS%id_itidal_loss_mode(fr,m) = register_diag_field('ocean_model', var_name, & - diag%axesT1, Time, var_descript, 'W m-2', conversion=US%R_to_kg_m3*US%Z_to_m**3*US%s_to_T**3) + diag%axesT1, Time, var_descript, 'W m-2', conversion=US%RZ3_T3_to_W_m2) call MOM_mesg("Registering "//trim(var_name)//", Described as: "//var_descript, 5) ! all loss processes write(var_name, '("Itide_allprocesses_loss_freq",i1,"_mode",i1)') fr, m write(var_descript, '("Internal tide energy loss due to all processes from frequency ",i1," mode ",i1)') fr, m CS%id_allprocesses_loss_mode(fr,m) = register_diag_field('ocean_model', var_name, & - diag%axesT1, Time, var_descript, 'W m-2', conversion=US%R_to_kg_m3*US%Z_to_m**3*US%s_to_T**3) + diag%axesT1, Time, var_descript, 'W m-2', conversion=US%RZ3_T3_to_W_m2) call MOM_mesg("Registering "//trim(var_name)//", Described as: "//var_descript, 5) ! Register 3-D (i,j,a) energy loss for each freq and mode @@ -2503,7 +2503,7 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) write(var_name, '("Itide_wavedrag_loss_ang_freq",i1,"_mode",i1)') fr, m write(var_descript, '("Internal tide energy loss due to wave-drag from frequency ",i1," mode ",i1)') fr, m CS%id_itidal_loss_ang_mode(fr,m) = register_diag_field('ocean_model', var_name, & - axes_ang, Time, var_descript, 'W m-2 band-1', conversion=US%R_to_kg_m3*US%Z_to_m**3*US%s_to_T**3) + axes_ang, Time, var_descript, 'W m-2 band-1', conversion=US%RZ3_T3_to_W_m2) call MOM_mesg("Registering "//trim(var_name)//", Described as: "//var_descript, 5) ! Register 2-D period-averaged near-bottom horizonal velocity for each freq and mode diff --git a/src/parameterizations/lateral/MOM_thickness_diffuse.F90 b/src/parameterizations/lateral/MOM_thickness_diffuse.F90 index 450d6fea9b..ed3fc7aa4c 100644 --- a/src/parameterizations/lateral/MOM_thickness_diffuse.F90 +++ b/src/parameterizations/lateral/MOM_thickness_diffuse.F90 @@ -1923,7 +1923,7 @@ subroutine thickness_diffuse_init(Time, G, GV, US, param_file, diag, CDp, CS) CS%id_GMwork = register_diag_field('ocean_model', 'GMwork', diag%axesT1, Time, & 'Integrated Tendency of Ocean Mesoscale Eddy KE from Parameterized Eddy Advection', & - 'W m-2', conversion=US%R_to_kg_m3*US%Z_to_m*US%L_to_m**2*US%s_to_T**3, cmor_field_name='tnkebto', & + 'W m-2', conversion=US%RZ3_T3_to_W_m2*US%L_to_Z**2, cmor_field_name='tnkebto', & cmor_long_name='Integrated Tendency of Ocean Mesoscale Eddy KE from Parameterized Eddy Advection', & cmor_standard_name='tendency_of_ocean_eddy_kinetic_energy_content_due_to_parameterized_eddy_advection') if (CS%id_GMwork > 0) call safe_alloc_ptr(CS%GMwork,G%isd,G%ied,G%jsd,G%jed) diff --git a/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 b/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 index c910433172..8286251f0b 100644 --- a/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 +++ b/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 @@ -3594,8 +3594,8 @@ subroutine bulkmixedlayer_init(Time, G, GV, US, param_file, diag, CS) Time, 'Mean kinetic energy source of mixed layer TKE', & 'm3 s-3', conversion=US%Z_to_m*(US%L_to_m**2)*(US%s_to_T**3)) CS%id_TKE_conv = register_diag_field('ocean_model', 'TKE_conv', diag%axesT1, & - Time, 'Convective source of mixed layer TKE', 'm3 s-3', & - conversion=US%Z_to_m*(US%L_to_m**2)*(US%s_to_T**3)) + Time, 'Convective source of mixed layer TKE', & + 'm3 s-3', conversion=US%Z_to_m*(US%L_to_m**2)*(US%s_to_T**3)) CS%id_TKE_pen_SW = register_diag_field('ocean_model', 'TKE_pen_SW', diag%axesT1, & Time, 'TKE consumed by mixing penetrative shortwave radation through the mixed layer', & 'm3 s-3', conversion=US%Z_to_m*(US%L_to_m**2)*(US%s_to_T**3)) @@ -3613,10 +3613,10 @@ subroutine bulkmixedlayer_init(Time, G, GV, US, param_file, diag, CS) 'm3 s-3', conversion=US%Z_to_m*(US%L_to_m**2)*(US%s_to_T**3)) CS%id_PE_detrain = register_diag_field('ocean_model', 'PE_detrain', diag%axesT1, & Time, 'Spurious source of potential energy from mixed layer detrainment', & - 'W m-2', conversion=US%R_to_kg_m3*US%Z_to_m*(US%L_to_m**2)*(US%s_to_T**3)) + 'W m-2', conversion=US%RZ3_T3_to_W_m2*US%L_to_Z**2) CS%id_PE_detrain2 = register_diag_field('ocean_model', 'PE_detrain2', diag%axesT1, & Time, 'Spurious source of potential energy from mixed layer only detrainment', & - 'W m-2', conversion=US%R_to_kg_m3*US%Z_to_m*(US%L_to_m**2)*(US%s_to_T**3)) + 'W m-2', conversion=US%RZ3_T3_to_W_m2*US%L_to_Z**2) CS%id_h_mismatch = register_diag_field('ocean_model', 'h_miss_ML', diag%axesT1, & Time, 'Summed absolute mismatch in entrainment terms', 'm', conversion=US%Z_to_m) CS%id_Hsfc_used = register_diag_field('ocean_model', 'Hs_used', diag%axesT1, & diff --git a/src/parameterizations/vertical/MOM_diabatic_driver.F90 b/src/parameterizations/vertical/MOM_diabatic_driver.F90 index 787482d0e2..fb8b05c9e1 100644 --- a/src/parameterizations/vertical/MOM_diabatic_driver.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_driver.F90 @@ -832,7 +832,7 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Tim 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, & - scale=US%R_to_kg_m3*US%Z_to_m**3*US%s_to_T**2) + scale=US%RZ3_T3_to_W_m2*US%T_to_s) call hchksum(dSV_dT, "after applyBoundaryFluxes dSV_dT", G%HI, haloshift=0, scale=US%kg_m3_to_R) call hchksum(dSV_dS, "after applyBoundaryFluxes dSV_dS", G%HI, haloshift=0, scale=US%kg_m3_to_R) endif @@ -1562,7 +1562,7 @@ subroutine diabatic_ALE(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, 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, & - scale=US%R_to_kg_m3*US%Z_to_m**3*US%s_to_T**2) + scale=US%RZ3_T3_to_W_m2*US%T_to_s) call hchksum(dSV_dT, "after applyBoundaryFluxes dSV_dT",G%HI,haloshift=0, scale=US%kg_m3_to_R) call hchksum(dSV_dS, "after applyBoundaryFluxes dSV_dS",G%HI,haloshift=0, scale=US%kg_m3_to_R) endif @@ -3363,36 +3363,30 @@ subroutine diabatic_driver_init(Time, G, GV, US, param_file, useALEalgorithm, di ! Register all available diagnostics for this module. thickness_units = get_thickness_units(GV) - CS%id_ea_t = register_diag_field('ocean_model','ea_t',diag%axesTL,Time, & - 'Layer (heat) entrainment from above per timestep','m', & - conversion=GV%H_to_m) - CS%id_eb_t = register_diag_field('ocean_model','eb_t',diag%axesTL,Time, & - 'Layer (heat) entrainment from below per timestep', 'm', & - conversion=GV%H_to_m) - CS%id_ea_s = register_diag_field('ocean_model','ea_s',diag%axesTL,Time, & - 'Layer (salt) entrainment from above per timestep','m', & - conversion=GV%H_to_m) - CS%id_eb_s = register_diag_field('ocean_model','eb_s',diag%axesTL,Time, & - 'Layer (salt) entrainment from below per timestep', 'm', & - conversion=GV%H_to_m) + CS%id_ea_t = register_diag_field('ocean_model', 'ea_t', diag%axesTL, Time, & + 'Layer (heat) entrainment from above per timestep', 'm', conversion=GV%H_to_m) + CS%id_eb_t = register_diag_field('ocean_model', 'eb_t', diag%axesTL, Time, & + 'Layer (heat) entrainment from below per timestep', 'm', conversion=GV%H_to_m) + CS%id_ea_s = register_diag_field('ocean_model', 'ea_s', diag%axesTL, Time, & + 'Layer (salt) entrainment from above per timestep', 'm', conversion=GV%H_to_m) + CS%id_eb_s = register_diag_field('ocean_model', 'eb_s', diag%axesTL, Time, & + 'Layer (salt) entrainment from below per timestep', 'm', conversion=GV%H_to_m) ! used by layer diabatic - CS%id_ea = register_diag_field('ocean_model','ea',diag%axesTL,Time, & - 'Layer entrainment from above per timestep','m', & - conversion=GV%H_to_m) - CS%id_eb = register_diag_field('ocean_model','eb',diag%axesTL,Time, & - 'Layer entrainment from below per timestep', 'm', & - conversion=GV%H_to_m) - CS%id_wd = register_diag_field('ocean_model','wd',diag%axesTi,Time, & + CS%id_ea = register_diag_field('ocean_model', 'ea', diag%axesTL, Time, & + 'Layer entrainment from above per timestep', 'm', conversion=GV%H_to_m) + CS%id_eb = register_diag_field('ocean_model', 'eb', diag%axesTL, Time, & + 'Layer entrainment from below per timestep', 'm', conversion=GV%H_to_m) + CS%id_wd = register_diag_field('ocean_model', 'wd', diag%axesTi, Time, & 'Diapycnal velocity', 'm s-1', conversion=GV%H_to_m) if (CS%id_wd > 0) call safe_alloc_ptr(CDp%diapyc_vel,isd,ied,jsd,jed,nz+1) - CS%id_dudt_dia = register_diag_field('ocean_model','dudt_dia',diag%axesCuL,Time, & + CS%id_dudt_dia = register_diag_field('ocean_model', 'dudt_dia', diag%axesCuL, Time, & 'Zonal Acceleration from Diapycnal Mixing', 'm s-2', conversion=US%L_T2_to_m_s2) - CS%id_dvdt_dia = register_diag_field('ocean_model','dvdt_dia',diag%axesCvL,Time, & + CS%id_dvdt_dia = register_diag_field('ocean_model', 'dvdt_dia', diag%axesCvL, Time, & 'Meridional Acceleration from Diapycnal Mixing', 'm s-2', conversion=US%L_T2_to_m_s2) if (CS%use_int_tides) then - CS%id_cg1 = register_diag_field('ocean_model','cn1', diag%axesT1, & + CS%id_cg1 = register_diag_field('ocean_model', 'cn1', diag%axesT1, & Time, 'First baroclinic mode (eigen) speed', 'm s-1') allocate(CS%id_cn(CS%nMode)) ; CS%id_cn(:) = -1 do m=1,CS%nMode @@ -3405,31 +3399,31 @@ subroutine diabatic_driver_init(Time, G, GV, US, param_file, useALEalgorithm, di endif if (use_temperature) then - CS%id_Tdif = register_diag_field('ocean_model',"Tflx_dia_diff",diag%axesTi, & + CS%id_Tdif = register_diag_field('ocean_model',"Tflx_dia_diff", diag%axesTi, & Time, "Diffusive diapycnal temperature flux across interfaces", & "degC m s-1", conversion=GV%H_to_m*US%s_to_T) - CS%id_Tadv = register_diag_field('ocean_model',"Tflx_dia_adv",diag%axesTi, & + CS%id_Tadv = register_diag_field('ocean_model',"Tflx_dia_adv", diag%axesTi, & Time, "Advective diapycnal temperature flux across interfaces", & "degC m s-1", conversion=GV%H_to_m*US%s_to_T) - CS%id_Sdif = register_diag_field('ocean_model',"Sflx_dia_diff",diag%axesTi, & + CS%id_Sdif = register_diag_field('ocean_model',"Sflx_dia_diff", diag%axesTi, & Time, "Diffusive diapycnal salnity flux across interfaces", & "psu m s-1", conversion=GV%H_to_m*US%s_to_T) - CS%id_Sadv = register_diag_field('ocean_model',"Sflx_dia_adv",diag%axesTi, & + CS%id_Sadv = register_diag_field('ocean_model',"Sflx_dia_adv", diag%axesTi, & Time, "Advective diapycnal salnity flux across interfaces", & "psu m s-1", conversion=GV%H_to_m*US%s_to_T) CS%id_MLD_003 = register_diag_field('ocean_model', 'MLD_003', diag%axesT1, Time, & 'Mixed layer depth (delta rho = 0.03)', 'm', conversion=US%Z_to_m, & cmor_field_name='mlotst', cmor_long_name='Ocean Mixed Layer Thickness Defined by Sigma T', & cmor_standard_name='ocean_mixed_layer_thickness_defined_by_sigma_t') - CS%id_mlotstsq = register_diag_field('ocean_model','mlotstsq',diag%axesT1, Time, & + CS%id_mlotstsq = register_diag_field('ocean_model', 'mlotstsq', diag%axesT1, Time, & long_name='Square of Ocean Mixed Layer Thickness Defined by Sigma T', & standard_name='square_of_ocean_mixed_layer_thickness_defined_by_sigma_t', & units='m2', conversion=US%Z_to_m**2) - CS%id_MLD_0125 = register_diag_field('ocean_model','MLD_0125',diag%axesT1,Time, & + CS%id_MLD_0125 = register_diag_field('ocean_model', 'MLD_0125', diag%axesT1, Time, & 'Mixed layer depth (delta rho = 0.125)', 'm', conversion=US%Z_to_m) - CS%id_subMLN2 = register_diag_field('ocean_model','subML_N2',diag%axesT1,Time, & + CS%id_subMLN2 = register_diag_field('ocean_model', 'subML_N2', diag%axesT1, Time, & 'Squared buoyancy frequency below mixed layer', 's-2', conversion=US%s_to_T**2) - CS%id_MLD_user = register_diag_field('ocean_model','MLD_user',diag%axesT1,Time, & + CS%id_MLD_user = register_diag_field('ocean_model', 'MLD_user', diag%axesT1, Time, & 'Mixed layer depth (used defined)', 'm', conversion=US%Z_to_m) endif call get_param(param_file, mdl, "DIAG_MLD_DENSITY_DIFF", CS%MLDdensityDifference, & @@ -3452,8 +3446,8 @@ subroutine diabatic_driver_init(Time, G, GV, US, param_file, useALEalgorithm, di CS%id_v_predia = register_diag_field('ocean_model', 'v_predia', diag%axesCvL, Time, & 'Meridional velocity before diabatic forcing', 'm s-1', conversion=US%L_T_to_m_s) CS%id_h_predia = register_diag_field('ocean_model', 'h_predia', diag%axesTL, Time, & - 'Layer Thickness before diabatic forcing', trim(thickness_units), & - conversion=GV%H_to_MKS, v_extensive=.true.) + 'Layer Thickness before diabatic forcing', & + trim(thickness_units), conversion=GV%H_to_MKS, v_extensive=.true.) CS%id_e_predia = register_diag_field('ocean_model', 'e_predia', diag%axesTi, Time, & 'Interface Heights before diabatic forcing', 'm') if (use_temperature) then @@ -3508,8 +3502,8 @@ subroutine diabatic_driver_init(Time, G, GV, US, param_file, useALEalgorithm, di default=.false.) if (CS%salt_reject_below_ML) then - CS%id_brine_lay = register_diag_field('ocean_model','brine_layer',diag%axesT1,Time, & - 'Brine insertion layer','none') + CS%id_brine_lay = register_diag_field('ocean_model', 'brine_layer', diag%axesT1, Time, & + 'Brine insertion layer', 'none') endif @@ -3517,8 +3511,8 @@ subroutine diabatic_driver_init(Time, G, GV, US, param_file, useALEalgorithm, di ! 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, & - long_name='Cell thickness used during diabatic diffusion', units='m', & - conversion=GV%H_to_m, v_extensive=.true.) + long_name='Cell thickness used during diabatic diffusion', & + units='m', conversion=GV%H_to_m, v_extensive=.true.) if (CS%useALEalgorithm) then CS%id_diabatic_diff_temp_tend = register_diag_field('ocean_model', & 'diabatic_diff_temp_tendency', diag%axesTL, Time, & @@ -3550,7 +3544,7 @@ subroutine diabatic_driver_init(Time, G, GV, US, param_file, useALEalgorithm, di 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', conversion=US%R_to_kg_m3*US%Z_to_m*US%s_to_T, cmor_field_name='osaltdiff', & + 'kg m-2 s-1', conversion=US%RZ_T_to_kg_m2s, 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 '// & @@ -3577,7 +3571,7 @@ subroutine diabatic_driver_init(Time, G, GV, US, param_file, useALEalgorithm, di 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', conversion=US%R_to_kg_m3*US%Z_to_m*US%s_to_T, cmor_field_name='osaltdiff_2d', & + 'kg m-2 s-1', conversion=US%RZ_T_to_kg_m2s, 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 '// & @@ -3590,8 +3584,8 @@ subroutine diabatic_driver_init(Time, G, GV, US, param_file, useALEalgorithm, di ! 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, & - long_name='Cell thickness after applying boundary forcing', units='m', & - conversion=GV%H_to_m, v_extensive=.true.) + long_name='Cell thickness after applying boundary forcing', & + units='m', conversion=GV%H_to_m, v_extensive=.true.) CS%id_boundary_forcing_h_tendency = register_diag_field('ocean_model', & 'boundary_forcing_h_tendency', diag%axesTL, Time, & 'Cell thickness tendency due to boundary forcing', 'm s-1', conversion=US%s_to_T, & @@ -3624,7 +3618,7 @@ subroutine diabatic_driver_init(Time, G, GV, US, param_file, useALEalgorithm, di CS%id_boundary_forcing_salt_tend = register_diag_field('ocean_model',& 'boundary_forcing_salt_tendency', diag%axesTL, Time, & - 'Boundary forcing salt tendency', 'kg m-2 s-1', conversion=US%R_to_kg_m3*US%Z_to_m*US%s_to_T, & + 'Boundary forcing salt tendency', 'kg m-2 s-1', conversion=US%RZ_T_to_kg_m2s, & v_extensive = .true.) if (CS%id_boundary_forcing_salt_tend > 0) then CS%boundary_forcing_tendency_diag = .true. @@ -3643,7 +3637,7 @@ subroutine diabatic_driver_init(Time, G, GV, US, param_file, useALEalgorithm, di CS%id_boundary_forcing_salt_tend_2d = register_diag_field('ocean_model',& 'boundary_forcing_salt_tendency_2d', diag%axesT1, Time, & 'Depth integrated boundary forcing of ocean salt', & - 'kg m-2 s-1', conversion=US%R_to_kg_m3*US%Z_to_m*US%s_to_T) + 'kg m-2 s-1', conversion=US%RZ_T_to_kg_m2s) if (CS%id_boundary_forcing_salt_tend_2d > 0) then CS%boundary_forcing_tendency_diag = .true. endif @@ -3651,8 +3645,8 @@ subroutine diabatic_driver_init(Time, G, GV, US, param_file, useALEalgorithm, di ! diagnostics for tendencies of temp and heat due to frazil CS%id_frazil_h = register_diag_field('ocean_model', 'frazil_h', diag%axesTL, Time, & - long_name='Cell Thickness', standard_name='cell_thickness', units='m', & - conversion=GV%H_to_m, v_extensive=.true.) + long_name='Cell Thickness', standard_name='cell_thickness', & + units='m', conversion=GV%H_to_m, v_extensive=.true.) ! diagnostic for tendency of temp due to frazil CS%id_frazil_temp_tend = register_diag_field('ocean_model',& diff --git a/src/parameterizations/vertical/MOM_energetic_PBL.F90 b/src/parameterizations/vertical/MOM_energetic_PBL.F90 index 962dcb455e..b4fad24a60 100644 --- a/src/parameterizations/vertical/MOM_energetic_PBL.F90 +++ b/src/parameterizations/vertical/MOM_energetic_PBL.F90 @@ -1947,7 +1947,6 @@ subroutine energetic_PBL_init(Time, G, GV, US, param_file, diag, CS) character(len=40) :: mdl = "MOM_energetic_PBL" ! This module's name. character(len=20) :: tmpstr real :: omega_frac_dflt - real :: R_Z3_T3_to_kg_s3 ! A conversion factor for work diagnostics [kg T3 R-1 Z-3 s-3 ~> nondim] integer :: isd, ied, jsd, jed integer :: mstar_mode, LT_enhance, wT_mode logical :: default_2018_answers @@ -2304,25 +2303,25 @@ subroutine energetic_PBL_init(Time, G, GV, US, param_file, diag, CS) !/ Checking output flags - R_Z3_T3_to_kg_s3 = US%R_to_kg_m3 * US%Z_to_m**3 * US%s_to_T**3 + !### Most of these units are wrong and should be W m-2 CS%id_ML_depth = register_diag_field('ocean_model', 'ePBL_h_ML', diag%axesT1, & Time, 'Surface boundary layer depth', 'm', conversion=US%Z_to_m, & cmor_long_name='Ocean Mixed Layer Thickness Defined by Mixing Scheme') CS%id_TKE_wind = register_diag_field('ocean_model', 'ePBL_TKE_wind', diag%axesT1, & - Time, 'Wind-stirring source of mixed layer TKE', 'm3 s-3', conversion=R_Z3_T3_to_kg_s3) + Time, 'Wind-stirring source of mixed layer TKE', 'm3 s-3', conversion=US%RZ3_T3_to_W_m2) CS%id_TKE_MKE = register_diag_field('ocean_model', 'ePBL_TKE_MKE', diag%axesT1, & - Time, 'Mean kinetic energy source of mixed layer TKE', 'm3 s-3', conversion=R_Z3_T3_to_kg_s3) + Time, 'Mean kinetic energy source of mixed layer TKE', 'm3 s-3', conversion=US%RZ3_T3_to_W_m2) CS%id_TKE_conv = register_diag_field('ocean_model', 'ePBL_TKE_conv', diag%axesT1, & - Time, 'Convective source of mixed layer TKE', 'm3 s-3', conversion=R_Z3_T3_to_kg_s3) + Time, 'Convective source of mixed layer TKE', 'm3 s-3', conversion=US%RZ3_T3_to_W_m2) CS%id_TKE_forcing = register_diag_field('ocean_model', 'ePBL_TKE_forcing', diag%axesT1, & Time, 'TKE consumed by mixing surface forcing or penetrative shortwave radation '//& - 'through model layers', 'm3 s-3', conversion=R_Z3_T3_to_kg_s3) + 'through model layers', 'm3 s-3', conversion=US%RZ3_T3_to_W_m2) CS%id_TKE_mixing = register_diag_field('ocean_model', 'ePBL_TKE_mixing', diag%axesT1, & - Time, 'TKE consumed by mixing that deepens the mixed layer', 'm3 s-3', conversion=R_Z3_T3_to_kg_s3) + Time, 'TKE consumed by mixing that deepens the mixed layer', 'm3 s-3', conversion=US%RZ3_T3_to_W_m2) CS%id_TKE_mech_decay = register_diag_field('ocean_model', 'ePBL_TKE_mech_decay', diag%axesT1, & - Time, 'Mechanical energy decay sink of mixed layer TKE', 'm3 s-3', conversion=R_Z3_T3_to_kg_s3) + Time, 'Mechanical energy decay sink of mixed layer TKE', 'm3 s-3', conversion=US%RZ3_T3_to_W_m2) CS%id_TKE_conv_decay = register_diag_field('ocean_model', 'ePBL_TKE_conv_decay', diag%axesT1, & - Time, 'Convective energy decay sink of mixed layer TKE', 'm3 s-3', conversion=R_Z3_T3_to_kg_s3) + Time, 'Convective energy decay sink of mixed layer TKE', 'm3 s-3', conversion=US%RZ3_T3_to_W_m2) CS%id_Mixing_Length = register_diag_field('ocean_model', 'Mixing_Length', diag%axesTi, & Time, 'Mixing Length that is used', 'm', conversion=US%Z_to_m) CS%id_Velocity_Scale = register_diag_field('ocean_model', 'Velocity_Scale', diag%axesTi, & diff --git a/src/parameterizations/vertical/MOM_entrain_diffusive.F90 b/src/parameterizations/vertical/MOM_entrain_diffusive.F90 index 76aa99ccc6..0fd691e7ab 100644 --- a/src/parameterizations/vertical/MOM_entrain_diffusive.F90 +++ b/src/parameterizations/vertical/MOM_entrain_diffusive.F90 @@ -2141,8 +2141,8 @@ subroutine entrain_diffusive_init(Time, G, GV, US, param_file, diag, CS) CS%id_Kd = register_diag_field('ocean_model', 'Kd_effective', diag%axesTL, Time, & 'Diapycnal diffusivity as applied', 'm2 s-1', conversion=US%Z2_T_to_m2_s) CS%id_diff_work = register_diag_field('ocean_model', 'diff_work', diag%axesTi, Time, & - 'Work actually done by diapycnal diffusion across each interface', 'W m-2', & - conversion=US%R_to_kg_m3*US%Z_to_m**3*US%s_to_T**3) + 'Work actually done by diapycnal diffusion across each interface', & + 'W m-2', conversion=US%RZ3_T3_to_W_m2) end subroutine entrain_diffusive_init diff --git a/src/parameterizations/vertical/MOM_internal_tide_input.F90 b/src/parameterizations/vertical/MOM_internal_tide_input.F90 index 01f583292f..8d31f19825 100644 --- a/src/parameterizations/vertical/MOM_internal_tide_input.F90 +++ b/src/parameterizations/vertical/MOM_internal_tide_input.F90 @@ -409,7 +409,7 @@ subroutine int_tide_input_init(Time, G, GV, US, param_file, diag, CS, itide) CS%id_TKE_itidal = register_diag_field('ocean_model','TKE_itidal_itide',diag%axesT1,Time, & 'Internal Tide Driven Turbulent Kinetic Energy', & - 'W m-2', conversion=US%R_to_kg_m3*US%Z_to_m**3*US%s_to_T**3) + 'W m-2', conversion=US%RZ3_T3_to_W_m2) CS%id_Nb = register_diag_field('ocean_model','Nb_itide',diag%axesT1,Time, & 'Bottom Buoyancy Frequency', 's-1', conversion=US%s_to_T) diff --git a/src/parameterizations/vertical/MOM_set_diffusivity.F90 b/src/parameterizations/vertical/MOM_set_diffusivity.F90 index eb1afb6bb8..5ee82aa7ca 100644 --- a/src/parameterizations/vertical/MOM_set_diffusivity.F90 +++ b/src/parameterizations/vertical/MOM_set_diffusivity.F90 @@ -2041,8 +2041,7 @@ subroutine set_diffusivity_init(Time, G, GV, US, param_file, diag, CS, int_tide_ CS%use_LOTW_BBL_diffusivity = .false. ! This parameterization depends on a u* from viscous BBL endif CS%id_Kd_BBL = register_diag_field('ocean_model', 'Kd_BBL', diag%axesTi, Time, & - 'Bottom Boundary Layer Diffusivity', 'm2 s-1', & - conversion=US%Z2_T_to_m2_s) + 'Bottom Boundary Layer Diffusivity', 'm2 s-1', conversion=US%Z2_T_to_m2_s) call get_param(param_file, mdl, "SIMPLE_TKE_TO_KD", CS%simple_TKE_to_Kd, & "If true, uses a simple estimate of Kd/TKE that will "//& "work for arbitrary vertical coordinates. If false, "//& @@ -2121,25 +2120,22 @@ subroutine set_diffusivity_init(Time, G, GV, US, param_file, diag, CS, int_tide_ CS%dissip_N2 = CS%dissip_Kd_min * GV%Rho0 / CS%FluxRi_max CS%id_Kd_layer = register_diag_field('ocean_model', 'Kd_layer', diag%axesTL, Time, & - 'Diapycnal diffusivity of layers (as set)', 'm2 s-1', & - conversion=US%Z2_T_to_m2_s) + 'Diapycnal diffusivity of layers (as set)', 'm2 s-1', conversion=US%Z2_T_to_m2_s) if (CS%tm_csp%Int_tide_dissipation .or. CS%tm_csp%Lee_wave_dissipation .or. & CS%tm_csp%Lowmode_itidal_dissipation) then CS%id_Kd_Work = register_diag_field('ocean_model', 'Kd_Work', diag%axesTL, Time, & - 'Work done by Diapycnal Mixing', 'W m-2', conversion=US%R_to_kg_m3*US%Z_to_m**3*US%s_to_T**3) + 'Work done by Diapycnal Mixing', 'W m-2', conversion=US%RZ3_T3_to_W_m2) CS%id_maxTKE = register_diag_field('ocean_model', 'maxTKE', diag%axesTL, Time, & 'Maximum layer TKE', 'm3 s-3', conversion=(US%Z_to_m**3*US%s_to_T**3)) CS%id_TKE_to_Kd = register_diag_field('ocean_model', 'TKE_to_Kd', diag%axesTL, Time, & - 'Convert TKE to Kd', 's2 m', & - conversion=US%Z2_T_to_m2_s*(US%m_to_Z**3*US%T_to_s**3)) + 'Convert TKE to Kd', 's2 m', conversion=US%Z2_T_to_m2_s*(US%m_to_Z**3*US%T_to_s**3)) CS%id_N2 = register_diag_field('ocean_model', 'N2', diag%axesTi, Time, & - 'Buoyancy frequency squared', 's-2', cmor_field_name='obvfsq', & + 'Buoyancy frequency squared', 's-2', conversion=US%s_to_T**2, cmor_field_name='obvfsq', & cmor_long_name='Square of seawater buoyancy frequency', & - cmor_standard_name='square_of_brunt_vaisala_frequency_in_sea_water', & - conversion=US%s_to_T**2) + cmor_standard_name='square_of_brunt_vaisala_frequency_in_sea_water') if (CS%user_change_diff) & CS%id_Kd_user = register_diag_field('ocean_model', 'Kd_user', diag%axesTi, Time, & @@ -2165,12 +2161,10 @@ subroutine set_diffusivity_init(Time, G, GV, US, param_file, diag, CS, int_tide_ ! The default molecular viscosity follows the CCSM4.0 and MOM4p1 defaults. CS%id_KT_extra = register_diag_field('ocean_model', 'KT_extra', diag%axesTi, Time, & - 'Double-diffusive diffusivity for temperature', 'm2 s-1', & - conversion=US%Z2_T_to_m2_s) + 'Double-diffusive diffusivity for temperature', 'm2 s-1', conversion=US%Z2_T_to_m2_s) CS%id_KS_extra = register_diag_field('ocean_model', 'KS_extra', diag%axesTi, Time, & - 'Double-diffusive diffusivity for salinity', 'm2 s-1', & - conversion=US%Z2_T_to_m2_s) + 'Double-diffusive diffusivity for salinity', 'm2 s-1', conversion=US%Z2_T_to_m2_s) endif ! old double-diffusion if (CS%user_change_diff) then diff --git a/src/parameterizations/vertical/MOM_tidal_mixing.F90 b/src/parameterizations/vertical/MOM_tidal_mixing.F90 index b96670e4b8..2ea4a95d7d 100644 --- a/src/parameterizations/vertical/MOM_tidal_mixing.F90 +++ b/src/parameterizations/vertical/MOM_tidal_mixing.F90 @@ -604,7 +604,7 @@ logical function tidal_mixing_init(Time, G, GV, US, param_file, diag, CS) else CS%id_TKE_itidal = register_diag_field('ocean_model','TKE_itidal',diag%axesT1,Time, & 'Internal Tide Driven Turbulent Kinetic Energy', & - 'W m-2', conversion=(US%R_to_kg_m3*US%Z_to_m**3*US%s_to_T**3)) + 'W m-2', conversion=US%RZ3_T3_to_W_m2) CS%id_Nb = register_diag_field('ocean_model','Nb',diag%axesT1,Time, & 'Bottom Buoyancy Frequency', 's-1', conversion=US%s_to_T) @@ -637,20 +637,20 @@ logical function tidal_mixing_init(Time, G, GV, US, param_file, diag, CS) CS%id_Kd_Itidal_Work = register_diag_field('ocean_model','Kd_Itidal_Work',diag%axesTL,Time, & 'Work done by Internal Tide Diapycnal Mixing', & - 'W m-2', conversion=(US%R_to_kg_m3*US%Z_to_m**3*US%s_to_T**3)) + 'W m-2', conversion=US%RZ3_T3_to_W_m2) CS%id_Kd_Niku_Work = register_diag_field('ocean_model','Kd_Nikurashin_Work',diag%axesTL,Time, & 'Work done by Nikurashin Lee Wave Drag Scheme', & - 'W m-2', conversion=(US%R_to_kg_m3*US%Z_to_m**3*US%s_to_T**3)) + 'W m-2', conversion=US%RZ3_T3_to_W_m2) CS%id_Kd_Lowmode_Work = register_diag_field('ocean_model','Kd_Lowmode_Work',diag%axesTL,Time, & 'Work done by Internal Tide Diapycnal Mixing (low modes)', & - 'W m-2', conversion=(US%R_to_kg_m3*US%Z_to_m**3*US%s_to_T**3)) + 'W m-2', conversion=US%RZ3_T3_to_W_m2) if (CS%Lee_wave_dissipation) then CS%id_TKE_leewave = register_diag_field('ocean_model','TKE_leewave',diag%axesT1,Time, & 'Lee wave Driven Turbulent Kinetic Energy', & - 'W m-2', conversion=(US%R_to_kg_m3*US%Z_to_m**3*US%s_to_T**3)) + 'W m-2', conversion=US%RZ3_T3_to_W_m2) CS%id_Kd_Niku = register_diag_field('ocean_model','Kd_Nikurashin',diag%axesTi,Time, & 'Lee Wave Driven Diffusivity', 'm2 s-1', conversion=US%Z2_T_to_m2_s) endif diff --git a/src/parameterizations/vertical/MOM_vert_friction.F90 b/src/parameterizations/vertical/MOM_vert_friction.F90 index 462b97788f..e3bc14955f 100644 --- a/src/parameterizations/vertical/MOM_vert_friction.F90 +++ b/src/parameterizations/vertical/MOM_vert_friction.F90 @@ -1748,10 +1748,10 @@ subroutine vertvisc_init(MIS, Time, G, GV, US, param_file, diag, ADp, dirs, & CS%id_taux_bot = register_diag_field('ocean_model', 'taux_bot', diag%axesCu1, & Time, 'Zonal Bottom Stress from Ocean to Earth', 'Pa', & - conversion=US%R_to_kg_m3*US%L_T2_to_m_s2*US%Z_to_m) + conversion=US%RZ_to_kg_m2*US%L_T2_to_m_s2) CS%id_tauy_bot = register_diag_field('ocean_model', 'tauy_bot', diag%axesCv1, & Time, 'Meridional Bottom Stress from Ocean to Earth', 'Pa', & - conversion=US%R_to_kg_m3*US%L_T2_to_m_s2*US%Z_to_m) + conversion=US%RZ_to_kg_m2*US%L_T2_to_m_s2) if ((len_trim(CS%u_trunc_file) > 0) .or. (len_trim(CS%v_trunc_file) > 0)) & call PointAccel_init(MIS, Time, G, param_file, diag, dirs, CS%PointAccel_CSp) diff --git a/src/tracer/MOM_generic_tracer.F90 b/src/tracer/MOM_generic_tracer.F90 index cae084f120..83c2c9a8e7 100644 --- a/src/tracer/MOM_generic_tracer.F90 +++ b/src/tracer/MOM_generic_tracer.F90 @@ -459,7 +459,7 @@ subroutine MOM_generic_tracer_column_physics(h_old, h_new, ea, eb, fluxes, Hml, call g_tracer_get_pointer(g_tracer,g_tracer_name,'runoff_tracer_flux',runoff_tracer_flux_array) !nnz: Why is fluxes%river = 0? runoff_tracer_flux_array(:,:) = trunoff_array(:,:) * & - G%US%R_to_kg_m3*G%US%Z_to_m*G%US%s_to_T*fluxes%lrunoff(:,:) + G%US%RZ_T_to_kg_m2s*fluxes%lrunoff(:,:) stf_array = stf_array + runoff_tracer_flux_array endif @@ -492,7 +492,7 @@ subroutine MOM_generic_tracer_column_physics(h_old, h_new, ea, eb, fluxes, Hml, ! !Calculate tendencies (i.e., field changes at dt) from the sources / sinks ! - if ((G%US%L_to_m == 1.0) .and. (G%US%R_to_kg_m3*G%US%Z_to_m == 1.0) .and. (G%US%s_to_T == 1.0)) then + if ((G%US%L_to_m == 1.0) .and. (G%US%RZ_to_kg_m2 == 1.0) .and. (G%US%s_to_T == 1.0)) then ! Avoid unnecessary copies when no unit conversion is needed. call generic_tracer_source(tv%T, tv%S, rho_dzt, dzt, Hml, G%isd, G%jsd, 1, dt, & G%areaT, get_diag_time_end(CS%diag), & @@ -502,8 +502,8 @@ subroutine MOM_generic_tracer_column_physics(h_old, h_new, ea, eb, fluxes, Hml, call generic_tracer_source(tv%T, tv%S, rho_dzt, dzt, Hml, G%isd, G%jsd, 1, dt, & G%US%L_to_m**2*G%areaT(:,:), get_diag_time_end(CS%diag), & optics%nbands, optics%max_wavelength_band, optics%sw_pen_band, optics%opacity_band, & - internal_heat=G%US%R_to_kg_m3*G%US%Z_to_m*tv%internal_heat(:,:), & - frunoff=G%US%R_to_kg_m3*G%US%Z_to_m*G%US%s_to_T*fluxes%frunoff(:,:), sosga=sosga) + internal_heat=G%US%RZ_to_kg_m2*tv%internal_heat(:,:), & + frunoff=G%US%RZ_T_to_kg_m2s*fluxes%frunoff(:,:), sosga=sosga) endif ! This uses applyTracerBoundaryFluxesInOut to handle the change in tracer due to freshwater fluxes From b4f57f7433d790d54aa186df9fd7b855d4f79659 Mon Sep 17 00:00:00 2001 From: Matthew Harrison Date: Tue, 25 Feb 2020 12:12:44 -0500 Subject: [PATCH 086/316] original version of find_limited_slope --- src/tracer/MOM_tracer_Z_init.F90 | 44 ++++++++++++++++++-------------- 1 file changed, 25 insertions(+), 19 deletions(-) diff --git a/src/tracer/MOM_tracer_Z_init.F90 b/src/tracer/MOM_tracer_Z_init.F90 index f09c0e51c8..128427c683 100644 --- a/src/tracer/MOM_tracer_Z_init.F90 +++ b/src/tracer/MOM_tracer_Z_init.F90 @@ -577,30 +577,36 @@ subroutine find_overlap(e, Z_top, Z_bot, k_max, k_start, k_top, k_bot, wt, z1, z end subroutine find_overlap -!> This function determines a limited slope for val to be advected with +!> This subroutine determines a limited slope for val to be advected with !! a piecewise limited scheme. function find_limited_slope(val, e, k) result(slope) - real, dimension(:), intent(in) :: val !< A column of values that are being interpolated, in arbitrary units [A]. - real, dimension(:), intent(in) :: e !< A column's interface heights [Z ~> m] or other units. - integer, intent(in) :: k !< The layer whose slope is being determined. - real :: slope !< The normalized slope in the intracell distribution of - !! val [A Z-1 ~> A m-1] or other units. + real, dimension(:), intent(in) :: val !< An column the values that are being interpolated. + real, dimension(:), intent(in) :: e !< A column's interface heights [Z ~> m] or other units. + integer, intent(in) :: k !< The layer whose slope is being determined. + real :: slope !< The normalized slope in the intracell distribution of val. ! Local variables - real :: d1, d2 ! Thicknesses in the units of e [Z ~> m]. + real :: amn, cmn + real :: d1, d2 - d1 = 0.5*(e(K-1)-e(K+1)) ; d2 = 0.5*(e(K)-e(K+2)) - if (((val(k)-val(k-1)) * (val(k)-val(k+1)) >= 0.0) .or. (d1*d2 <= 0.0)) then - slope = 0.0 + if ((val(k)-val(k-1)) * (val(k)-val(k+1)) >= 0.0) then + slope = 0.0 ! ; curvature = 0.0 else - ! This line has an extra set of parentheses on the second line, so it gives slightly - ! different answers than the version of find_limited_slope in midas_vertmap.F90. - slope = ((d1**2)*(val(k+1) - val(k)) + (d2**2)*(val(k) - val(k-1))) * & - ((e(K) - e(K+1)) / (d1*d2*(d1+d2))) - ! slope = 0.5*(val(k+1) - val(k-1)) - ! This is S.J. Lin's form of the PLM limiter. - slope = sign(1.0, slope) * min(abs(slope), & - 2.0*(max(val(k-1), val(k), val(k+1)) - val(k)), & - 2.0*(val(k) - min(val(k-1), val(k), val(k+1)))) + d1 = 0.5*(e(K-1)-e(K+1)) ; d2 = 0.5*(e(K)-e(K+2)) + if (d1*d2 > 0.0) then + slope = ((d1**2)*(val(k+1) - val(k)) + (d2**2)*(val(k) - val(k-1))) * & + (e(K) - e(K+1)) / (d1*d2*(d1+d2)) + ! slope = 0.5*(val(k+1) - val(k-1)) + ! This is S.J. Lin's form of the PLM limiter. + amn = min(abs(slope), 2.0*(max(val(k-1), val(k), val(k+1)) - val(k))) + cmn = 2.0*(val(k) - min(val(k-1), val(k), val(k+1))) + slope = sign(1.0, slope) * min(amn, cmn) + + ! min(abs(slope), 2.0*(max(val(k-1),val(k),val(k+1)) - val(k)), & + ! 2.0*(val(k) - min(val(k-1),val(k),val(k+1)))) + ! curvature = 0.0 + else + slope = 0.0 ! ; curvature = 0.0 + endif endif end function find_limited_slope From a77e5df927d61ccf36a9ce35fdce71315e93b59c Mon Sep 17 00:00:00 2001 From: Kate Hedstrom Date: Tue, 25 Feb 2020 14:07:54 -0900 Subject: [PATCH 087/316] OBC fussing, Hallberg's suggestion --- src/core/MOM_open_boundary.F90 | 20 ++++++++------------ 1 file changed, 8 insertions(+), 12 deletions(-) diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index 2214e3d6be..d4debfccea 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -1960,9 +1960,8 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, US, dt) dhdy = segment%grad_normal(J,1,k) endif if (dhdt*dhdx < 0.0) dhdt = 0.0 - rx_new = dhdt*dhdx cff_new = max(dhdx*dhdx + dhdy*dhdy, eps) - rx_new = min(rx_new, cff_new*rx_max) + rx_new = min(dhdt*dhdx, cff_new*rx_max) ry_new = min(cff_new,max(dhdt*dhdy,-cff_new)) if (gamma_u < 1.0) then rx_avg = (1.0-gamma_u)*segment%rx_norm_obl(I,j,k) + gamma_u*rx_new @@ -2103,8 +2102,8 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, US, dt) dhdy = segment%grad_tan(j+1,1,k) endif if (dhdt*dhdx < 0.0) dhdt = 0.0 - rx_new = dhdt*dhdx cff_new = max(dhdx*dhdx + dhdy*dhdy, eps) + rx_new = min(dhdt*dhdx, cff_new*rx_max) ry_new = min(cff_new,max(dhdt*dhdy,-cff_new)) rx_tang_obl(I,j,k) = rx_new ry_tang_obl(i,J,k) = ry_new @@ -2206,9 +2205,8 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, US, dt) endif if (dhdt*dhdx < 0.0) dhdt = 0.0 - rx_new = dhdt*dhdx cff_new = max(dhdx*dhdx + dhdy*dhdy, eps) - rx_new = min(rx_new, cff_new*rx_max) + rx_new = min(dhdt*dhdx, cff_new*rx_max) ry_new = min(cff_new,max(dhdt*dhdy,-cff_new)) if (gamma_u < 1.0) then rx_avg = (1.0-gamma_u)*segment%rx_norm_obl(I,j,k) + gamma_u*rx_new @@ -2349,8 +2347,8 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, US, dt) dhdy = segment%grad_tan(j+1,1,k) endif if (dhdt*dhdx < 0.0) dhdt = 0.0 - rx_new = dhdt*dhdx cff_new = max(dhdx*dhdx + dhdy*dhdy, eps) + rx_new = min(dhdt*dhdx, cff_new*rx_max) ry_new = min(cff_new,max(dhdt*dhdy,-cff_new)) rx_tang_obl(I,j,k) = rx_new ry_tang_obl(i,J,k) = ry_new @@ -2451,9 +2449,8 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, US, dt) dhdx = segment%grad_normal(I,1,k) endif if (dhdt*dhdy < 0.0) dhdt = 0.0 - ry_new = dhdt*dhdy cff_new = max(dhdx*dhdx + dhdy*dhdy, eps) - ry_new = min(ry_new, cff_new*ry_max) + ry_new = min(dhdt*dhdy, cff_new*ry_max) rx_new = min(cff_new,max(dhdt*dhdx,-cff_new)) if (gamma_u < 1.0) then rx_avg = (1.0-gamma_u)*segment%rx_norm_obl(I,j,k) + gamma_u*rx_new @@ -2594,8 +2591,8 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, US, dt) dhdx = segment%grad_tan(i+1,1,k) endif if (dhdt*dhdy < 0.0) dhdt = 0.0 - ry_new = dhdt*dhdy cff_new = max(dhdx*dhdx + dhdy*dhdy, eps) + ry_new = min(dhdt*dhdy, cff_new*ry_max) rx_new = min(cff_new,max(dhdt*dhdx,-cff_new)) rx_tang_obl(I,j,k) = rx_new ry_tang_obl(i,J,k) = ry_new @@ -2697,9 +2694,8 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, US, dt) endif if (dhdt*dhdy < 0.0) dhdt = 0.0 - ry_new = dhdt*dhdy cff_new = max(dhdx*dhdx + dhdy*dhdy, eps) - ry_new = min(ry_new, cff_new*ry_max) + ry_new = min(dhdt*dhdy, cff_new*ry_max) rx_new = min(cff_new,max(dhdt*dhdx,-cff_new)) if (gamma_u < 1.0) then rx_avg = (1.0-gamma_u)*segment%rx_norm_obl(I,j,k) + gamma_u*rx_new @@ -2840,8 +2836,8 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, US, dt) dhdx = segment%grad_tan(i+1,1,k) endif if (dhdt*dhdy < 0.0) dhdt = 0.0 - ry_new = dhdt*dhdy cff_new = max(dhdx*dhdx + dhdy*dhdy, eps) + ry_new = min(dhdt*dhdy, cff_new*ry_max) rx_new = min(cff_new,max(dhdt*dhdx,-cff_new)) rx_tang_obl(I,j,k) = rx_new ry_tang_obl(i,J,k) = ry_new From 830018a8e02a1007a227590b8359a72b6f207b06 Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Fri, 28 Feb 2020 17:36:46 -0500 Subject: [PATCH 088/316] Build in .testing; use relative paths This patch moves the `build` directory and contents generated by the test Makefile into the `.testing` directory. The `deps` directory has also been removed and its contents moved inside of `build`. Path names used for build rules have also been changed to use relative paths to `.testing`. In addition to streamlining the Makefile, it also simplifies the command lines rules for building individual targets, e.g. `build/symmetric/MOM6` to build the (default) symmetric-grid executable. --- .testing/Makefile | 73 +++++++++++++++++++++++------------------------ 1 file changed, 35 insertions(+), 38 deletions(-) diff --git a/.testing/Makefile b/.testing/Makefile index 645b9dc8f8..6710769c38 100644 --- a/.testing/Makefile +++ b/.testing/Makefile @@ -9,20 +9,17 @@ DO_REPRO_TESTS ?= true #--- # Dependencies -BASE = $(dir $(abspath $(lastword $(MAKEFILE_LIST))))/.. -DEPS = $(BASE)/deps -BUILD = $(BASE)/build # mkmf, list_paths (GFDL build toolchain) MKMF_URL ?= https://github.com/NOAA-GFDL/mkmf.git MKMF_COMMIT ?= master -LIST_PATHS := $(abspath $(DEPS)/mkmf/bin/list_paths) -MKMF := $(abspath $(DEPS)/mkmf/bin/mkmf) +LIST_PATHS := $(abspath build/mkmf/bin/list_paths) +MKMF := $(abspath build/mkmf/bin/mkmf) # FMS framework FMS_URL ?= https://github.com/NOAA-GFDL/FMS.git FMS_COMMIT ?= f2e2c86f6c0eb6d389a20509a8a60fa22924e16b -FMS := $(DEPS)/fms +FMS := build/fms #--- # Build configuration @@ -33,8 +30,8 @@ MKMF_CPP = "-Duse_libMPI -Duse_netCDF -DSPMD" # Environment # TODO: This info ought to be determined by CMake, automake, etc. #MKMF_TEMPLATE ?= .testing/linux-ubuntu-xenial-gnu.mk -MKMF_TEMPLATE ?= $(DEPS)/mkmf/templates/ncrc-gnu.mk -#MKMF_TEMPLATE ?= $(DEPS)/mkmf/templates/ncrc-intel.mk +MKMF_TEMPLATE ?= build/mkmf/templates/ncrc-gnu.mk +#MKMF_TEMPLATE ?= build/mkmf/templates/ncrc-intel.mk #--- # Test configuration @@ -71,67 +68,67 @@ ifeq ($(DO_REGRESSION_TESTS), true) MOM_TARGET_LOCAL_BRANCH ?= dev/gfdl MOM_TARGET_BRANCH := origin/$(MOM_TARGET_LOCAL_BRANCH) - TARGET_CODEBASE = $(BUILD)/target_codebase + TARGET_CODEBASE = build/target_codebase else MOM_TARGET_URL = MOM_TARGET_BRANCH = TARGET_CODEBASE = endif -SOURCE = $(wildcard $(BASE)/src/*/*.F90 $(BASE)/src/*/*/*.F90 $(BASE)/config_src/solo_driver/*.F90) +SOURCE = $(wildcard src/*/*.F90 src/*/*/*.F90 config_src/solo_driver/*.F90) #--- # Rules .PHONY: all build.regressions -all: $(foreach b,$(BUILDS),$(BUILD)/$(b)/MOM6) -build.regressions: $(foreach b,symmetric target,$(BUILD)/$(b)/MOM6) +all: $(foreach b,$(BUILDS),build/$(b)/MOM6) +build.regressions: $(foreach b,symmetric target,build/$(b)/MOM6) # Executable BUILD_TARGETS = MOM6 Makefile path_names -.PRECIOUS: $(foreach b,$(BUILDS),$(foreach f,$(BUILD_TARGETS),$(BUILD)/$(b)/$(f))) +.PRECIOUS: $(foreach b,$(BUILDS),$(foreach f,$(BUILD_TARGETS),build/$(b)/$(f))) # Conditionally build symmetric with coverage support COVFLAG=$(if $(REPORT_COVERAGE),COVERAGE=1,) -$(BUILD)/target/MOM6: MOMFLAGS=NETCDF=3 DEBUG=1 -$(BUILD)/symmetric/MOM6: MOMFLAGS=NETCDF=3 DEBUG=1 $(COVFLAG) -$(BUILD)/asymmetric/MOM6: MOMFLAGS=NETCDF=3 DEBUG=1 -$(BUILD)/repro/MOM6: MOMFLAGS=NETCDF=3 REPRO=1 -$(BUILD)/openmp/MOM6: MOMFLAGS=NETCDF=3 DEBUG=1 OPENMP=1 +build/target/MOM6: MOMFLAGS=NETCDF=3 DEBUG=1 +build/symmetric/MOM6: MOMFLAGS=NETCDF=3 DEBUG=1 $(COVFLAG) +build/asymmetric/MOM6: MOMFLAGS=NETCDF=3 DEBUG=1 +build/repro/MOM6: MOMFLAGS=NETCDF=3 REPRO=1 +build/openmp/MOM6: MOMFLAGS=NETCDF=3 DEBUG=1 OPENMP=1 -$(BUILD)/asymmetric/path_names: GRID_SRC=config_src/dynamic -$(BUILD)/%/path_names: GRID_SRC=config_src/dynamic_symmetric +build/asymmetric/path_names: GRID_SRC=config_src/dynamic +build/%/path_names: GRID_SRC=config_src/dynamic_symmetric -$(BUILD)/%/MOM6: $(BUILD)/%/Makefile $(FMS)/lib/libfms.a +build/%/MOM6: build/%/Makefile $(FMS)/lib/libfms.a make -C $(@D) $(MOMFLAGS) $(@F) -$(BUILD)/%/Makefile: $(BUILD)/%/path_names +build/%/Makefile: build/%/path_names cp $(MKMF_TEMPLATE) $(@D) cd $(@D) && $(MKMF) \ -t $(notdir $(MKMF_TEMPLATE)) \ - -o '-I $(FMS)/build' \ + -o '-I ../fms/build' \ -p MOM6 \ - -l '$(FMS)/lib/libfms.a' \ + -l '../fms/lib/libfms.a' \ -c $(MKMF_CPP) \ path_names # NOTE: These path_names rules could be merged -$(BUILD)/target/path_names: $(LIST_PATHS) $(TARGET_CODEBASE) +build/target/path_names: $(LIST_PATHS) $(TARGET_CODEBASE) mkdir -p $(@D) cd $(@D) && $(LIST_PATHS) -l \ - $(TARGET_CODEBASE)/src \ - $(TARGET_CODEBASE)/config_src/solo_driver \ - $(TARGET_CODEBASE)/$(GRID_SRC) + ../../$(TARGET_CODEBASE)/src \ + ../../$(TARGET_CODEBASE)/config_src/solo_driver \ + ../../$(TARGET_CODEBASE)/$(GRID_SRC) -$(BUILD)/%/path_names: $(LIST_PATHS) $(SOURCE) +build/%/path_names: $(LIST_PATHS) $(SOURCE) mkdir -p $(@D) cd $(@D) && $(LIST_PATHS) -l \ - $(BASE)/src \ - $(BASE)/config_src/solo_driver \ - $(BASE)/$(GRID_SRC) + ../../../src \ + ../../../config_src/solo_driver \ + ../../../$(GRID_SRC) # Target repository for regression tests $(TARGET_CODEBASE): @@ -167,8 +164,8 @@ $(FMS)/src: # Build Toolchain $(LIST_PATHS) $(MKMF): - git clone $(MKMF_URL) $(DEPS)/mkmf - cd $(DEPS)/mkmf; git checkout $(MKMF_COMMIT) + git clone $(MKMF_URL) build/mkmf + cd build/mkmf; git checkout $(MKMF_COMMIT) #---- @@ -247,8 +244,8 @@ endif # $(5): Environment variables # $(6): Number of MPI ranks define STAT_RULE -results/%/ocean.stats.$(1): ../build/$(2)/MOM6 - if [ $(3) ]; then find ../build/$(2) -name *.gcda -exec rm -f '{}' \; ; fi +results/%/ocean.stats.$(1): build/$(2)/MOM6 + if [ $(3) ]; then find build/$(2) -name *.gcda -exec rm -f '{}' \; ; fi mkdir -p work/$$*/$(1) cp -rL $$*/* work/$$*/$(1) cd work/$$*/$(1) && if [ -f Makefile ]; then make; fi @@ -282,7 +279,7 @@ $(eval $(call STAT_RULE,dim.h,symmetric,,H_RESCALE_POWER=11,,1)) $(eval $(call STAT_RULE,dim.z,symmetric,,Z_RESCALE_POWER=11,,1)) # Restart tests require significant preprocessing, and are handled separately. -results/%/ocean.stats.restart: ../build/symmetric/MOM6 +results/%/ocean.stats.restart: build/symmetric/MOM6 rm -rf work/$*/restart mkdir -p work/$*/restart cp -rL $*/* work/$*/restart @@ -321,7 +318,7 @@ results/%/ocean.stats.restart: ../build/symmetric/MOM6 clean: clean.stats @# Assert that we are in .testing for recursive delete @[ $$(basename $$(pwd)) = .testing ] - rm -rf ../build + rm -rf build .PHONY: clean.stats clean.stats: From 5d8f31a32cda47a0932c5e26fc70d5234a550a6e Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Sat, 29 Feb 2020 16:22:41 -0500 Subject: [PATCH 089/316] OBC: dz_src rescaling fixed in N-S segments When reading an OBC segment field from a file which is not V or DVDX, the field is remapped from the input file levels, set by dz_src, to the model levels, set by h, via remapping_core_h. When remapping on east-west segments, dz_src is rescaled to match the total width of h, saved in variable scl_fac. But this factor was not being applied on north-south segments. This was causing variations in rotated OBC simulations. This patch resovles the asymmetry by applying the rescaling along the N-S segments. --- src/core/MOM_open_boundary.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index 822ca6486f..9f5e4accfb 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -3730,7 +3730,7 @@ subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) 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)%nk_src, scl_fac*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 From 3af36a90f2fe1728c3a79532d13227884f8410d5 Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Tue, 3 Mar 2020 17:02:27 -0500 Subject: [PATCH 090/316] OBC: fix local_open_BC of PPM_reconstruction_y In PPM_reconstruction_y, the local_open_BC flag was set to the value of OBC%open_u_BCs_exist_globally, which is for the zonal velocity and is also used in the PPM_reconstruction_x function. This discrepancy was causing minor deviations in a dumbbell OBC test and its 90-degree rotation. This patch replaces the flag with OBC%open_v_BCs_exist_globally, for the meridional flow. --- src/core/MOM_continuity_PPM.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/core/MOM_continuity_PPM.F90 b/src/core/MOM_continuity_PPM.F90 index f91f0bcd46..eeaa3d8687 100644 --- a/src/core/MOM_continuity_PPM.F90 +++ b/src/core/MOM_continuity_PPM.F90 @@ -1979,7 +1979,7 @@ subroutine PPM_reconstruction_y(h_in, h_L, h_R, G, LB, h_min, monotonic, simple_ local_open_BC = .false. if (present(OBC)) then ; if (associated(OBC)) then - local_open_BC = OBC%open_u_BCs_exist_globally + local_open_BC = OBC%open_v_BCs_exist_globally endif ; endif isl = LB%ish ; iel = LB%ieh ; jsl = LB%jsh-1 ; jel = LB%jeh+1 From 7d219efb6591d938a9241694bdd8155b558e2c94 Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Thu, 5 Mar 2020 11:46:38 -0500 Subject: [PATCH 091/316] Source tree variable fix This fixes a bug in the SOURCE variable which was used to track files during development. It is generally unused for test builds. This was reworked to include support for FMS and the target repository. `SOURCE` is now a Makefile function which support MOM6 and FMS trees. We also extended it to catch other extensions: .inc .c .h These variables are used to link the top Makefile to the mkmf-generated makefiles, in order to trigger a rebuild via mkmf-makefile changes. I would not expect these `SOURCE` dependents to persist if we move to the autoconf build system. --- .testing/Makefile | 19 ++++++++++++++----- 1 file changed, 14 insertions(+), 5 deletions(-) diff --git a/.testing/Makefile b/.testing/Makefile index 6710769c38..0471499528 100644 --- a/.testing/Makefile +++ b/.testing/Makefile @@ -75,8 +75,17 @@ else TARGET_CODEBASE = endif -SOURCE = $(wildcard src/*/*.F90 src/*/*/*.F90 config_src/solo_driver/*.F90) - +# List of source files to link this Makefile's dependencies to model Makefiles +# Assumes a depth of two, and the following extensions: F90 inc c h +# (1): Root directory +# NOTE: extensions could be a second variable +SOURCE = \ + $(foreach ext,F90 inc c h,$(wildcard $(1)/*/*.$(ext) $(1)/*/*/*.$(ext))) + +MOM_SOURCE = $(call SOURCE,../src) $(wildcard ../config_src/solo_driver/*.F90) +TARGET_SOURCE = $(call SOURCE,build/target_codebase/src) \ + $(wildcard build/target_codebase/config_src/solo_driver/*.F90) +FMS_SOURCE = $(call SOURCE,build/fms/src) #--- # Rules @@ -116,14 +125,14 @@ build/%/Makefile: build/%/path_names # NOTE: These path_names rules could be merged -build/target/path_names: $(LIST_PATHS) $(TARGET_CODEBASE) +build/target/path_names: $(LIST_PATHS) $(TARGET_CODEBASE) $(TARGET_SOURCE) mkdir -p $(@D) cd $(@D) && $(LIST_PATHS) -l \ ../../$(TARGET_CODEBASE)/src \ ../../$(TARGET_CODEBASE)/config_src/solo_driver \ ../../$(TARGET_CODEBASE)/$(GRID_SRC) -build/%/path_names: $(LIST_PATHS) $(SOURCE) +build/%/path_names: $(LIST_PATHS) $(MOM_SOURCE) mkdir -p $(@D) cd $(@D) && $(LIST_PATHS) -l \ ../../../src \ @@ -151,7 +160,7 @@ $(FMS)/build/Makefile: $(FMS)/build/path_names -c $(MKMF_CPP) \ path_names -$(FMS)/build/path_names: $(FMS)/src $(FMS_FILES) $(LIST_PATHS) +$(FMS)/build/path_names: $(LIST_PATHS) $(FMS)/src $(FMS_SOURCE) mkdir -p $(@D) cd $(@D) && $(LIST_PATHS) -l ../src From ed51bcd6678cb6b07e031656d7955504a7e0d667 Mon Sep 17 00:00:00 2001 From: Andrew Shao Date: Fri, 6 Mar 2020 12:39:40 -0500 Subject: [PATCH 092/316] Modify remapping of vertically extensive diagnostics Vertically extensive diagnostics like advective transports, diffusive fluxes, etc. were being remapped onto a diagnostic grid prior to the physical process that chagne the tracer and/or layer thicknesses. However this means that the effective operator used for each component of a tracer budget was not the same, and so budgets could never be closed cell-by-cell in a diagnostic coordinate. This commit fixes one part of the inconsistency by setting the target diagnostic grid for all vertically extensive quantities to be one constructed at the very beginning of the timestep. However, problems with closing the budget should still be expected 1. Conservation of column integrals cannot be expected because the target grid can be smaller than the source grid (layer thicknesses at the native grid at the current point in the algorithm). This leads to some fluxes being 'thrown away' due to the reintegrate algorithm. 2. To truly have a consistent operator for all terms of a budget, the source grid for all vertically extensive grids should also be the same --- src/core/MOM.F90 | 4 +++ src/framework/MOM_diag_mediator.F90 | 49 ++++++++++++++++++++++------- src/framework/MOM_diag_remap.F90 | 23 ++++++++------ 3 files changed, 54 insertions(+), 22 deletions(-) diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index adb916298f..9e57fc2844 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -622,6 +622,10 @@ subroutine step_MOM(forces, fluxes, sfc_state, Time_start, time_int_in, CS, & if (showCallTree) call callTree_enter("DT cycles (step_MOM) n=",n) + ! Update the vertically extensive diagnostic grids so that they are + ! referenced to the beginning timestep + call diag_update_remap_grids(CS%diag, update_intensive = .false., update_extensive = .true. ) + !=========================================================================== ! This is the first place where the diabatic processes and remapping could occur. if (CS%diabatic_first .and. (CS%t_dyn_rel_adv==0.0) .and. do_thermo) then ! do thermodynamics. diff --git a/src/framework/MOM_diag_mediator.F90 b/src/framework/MOM_diag_mediator.F90 index 1fc012b7b9..a7fe44a93a 100644 --- a/src/framework/MOM_diag_mediator.F90 +++ b/src/framework/MOM_diag_mediator.F90 @@ -1473,14 +1473,16 @@ 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 => NULL() + if (id_clock_diag_mediator>0) call cpu_clock_begin(id_clock_diag_mediator) + + ! For intensive variables only, we can choose to use a different diagnostic grid + ! to map to if (present(alt_h)) then h_diag => alt_h else h_diag => diag_cs%h endif - if (id_clock_diag_mediator>0) call cpu_clock_begin(id_clock_diag_mediator) - ! Iterate over list of diag 'variants', e.g. CMOR aliases, different vertical ! grids, and post each. call assert(diag_field_id < diag_cs%next_free_diag_id, & @@ -1500,10 +1502,11 @@ subroutine post_data_3d(diag_field_id, field, diag_cs, is_static, mask, alt_h) if (id_clock_diag_remap>0) call cpu_clock_begin(id_clock_diag_remap) allocate(remapped_field(size(field,1), size(field,2), diag%axes%nz)) - call vertically_reintegrate_diag_field( & - diag_cs%diag_remap_cs(diag%axes%vertical_coordinate_number), & - diag_cs%G, h_diag, staggered_in_x, staggered_in_y, & - diag%axes%mask3d, diag_cs%missing_value, field, remapped_field) + call vertically_reintegrate_diag_field( & + diag_cs%diag_remap_cs(diag%axes%vertical_coordinate_number), diag_cs%G, & + diag_cs%diag_remap_cs(diag%axes%vertical_coordinate_number)%h_extensive, & + staggered_in_x, staggered_in_y, diag%axes%mask3d, diag_cs%missing_value, & + field, remapped_field) if (id_clock_diag_remap>0) call cpu_clock_end(id_clock_diag_remap) if (associated(diag%axes%mask3d)) then ! Since 3d masks do not vary in the vertical, just use as much as is @@ -3191,7 +3194,7 @@ subroutine diag_set_state_ptrs(h, T, S, eqn_of_state, diag_cs) !> Build/update vertical grids for diagnostic remapping. !! \note The target grids need to be updated whenever sea surface !! height changes. -subroutine diag_update_remap_grids(diag_cs, alt_h, alt_T, alt_S) +subroutine diag_update_remap_grids(diag_cs, alt_h, alt_T, alt_S, update_intensive, update_extensive ) type(diag_ctrl), intent(inout) :: diag_cs !< Diagnostics control structure real, target, optional, intent(in ) :: alt_h(:,:,:) !< Used if remapped grids should be something other than !! the current thicknesses [H ~> m or kg m-2] @@ -3199,11 +3202,17 @@ subroutine diag_update_remap_grids(diag_cs, alt_h, alt_T, alt_S) !! the current temperatures real, target, optional, intent(in ) :: alt_S(:,:,:) !< Used if remapped grids should be something other than !! the current salinity + logical, optional, intent(in ) :: update_intensive !< If true (default), update the grids used for + !! intensive diagnostics + logical, optional, intent(in ) :: update_extensive !< If true (not default), update the grids used for + !! intensive diagnostics ! Local variables integer :: i real, dimension(:,:,:), pointer :: h_diag => NULL() real, dimension(:,:,:), pointer :: T_diag => NULL(), S_diag => NULL() + logical :: update_intensive_local, update_extensive_local + ! Set values based on optional input arguments if (present(alt_h)) then h_diag => alt_h else @@ -3222,6 +3231,15 @@ subroutine diag_update_remap_grids(diag_cs, alt_h, alt_T, alt_S) S_diag => diag_CS%S endif + ! Defaults here are based on wanting to update intensive quantities frequently as soon as the model state changes. + ! Conversely, for extensive quantities, in an effort to close budgets and to be consistent with the total time + ! tendency, we construct the diagnostic grid at the beginning of the baroclinic timestep and remap all extensive + ! quantities to the same grid + update_intensive_local = .true. + if (present(update_intensive)) update_intensive_local = update_intensive + update_extensive_local = .false. + if (present(update_extensive)) update_extensive_local = update_extensive + if (id_clock_diag_grid_updates>0) call cpu_clock_begin(id_clock_diag_grid_updates) if (diag_cs%diag_grid_overridden) then @@ -3229,11 +3247,18 @@ subroutine diag_update_remap_grids(diag_cs, alt_h, alt_T, alt_S) "diagnostic structure have been overridden") endif - do i=1, diag_cs%num_diag_coords - call diag_remap_update(diag_cs%diag_remap_cs(i), & - diag_cs%G, diag_cs%GV, diag_cs%US, h_diag, T_diag, S_diag, & - diag_cs%eqn_of_state) - enddo + if (update_intensive_local) then + do i=1, diag_cs%num_diag_coords + call diag_remap_update(diag_cs%diag_remap_cs(i), diag_cs%G, diag_cs%GV, diag_cs%US, h_diag, T_diag, S_diag, & + diag_cs%eqn_of_state, diag_cs%diag_remap_cs(i)%h) + enddo + endif + if (update_extensive_local) then + do i=1, diag_cs%num_diag_coords + call diag_remap_update(diag_cs%diag_remap_cs(i), diag_cs%G, diag_cs%GV, diag_cs%US, h_diag, T_diag, S_diag, & + diag_cs%eqn_of_state, diag_cs%diag_remap_cs(i)%h_extensive) + enddo + endif #if defined(DEBUG) || defined(__DO_SAFETY_CHECKS__) ! Keep a copy of H - used to check whether grids are up-to-date diff --git a/src/framework/MOM_diag_remap.F90 b/src/framework/MOM_diag_remap.F90 index b61c10eb7e..81e7187786 100644 --- a/src/framework/MOM_diag_remap.F90 +++ b/src/framework/MOM_diag_remap.F90 @@ -112,6 +112,7 @@ module MOM_diag_remap type(regridding_CS) :: regrid_cs !< Regridding control structure that defines the coordiantes for this axes integer :: nz = 0 !< Number of vertical levels used for remapping real, dimension(:,:,:), allocatable :: h !< Remap grid thicknesses + real, dimension(:,:,:), allocatable :: h_extensive !< Remap grid thicknesses for extensive variables real, dimension(:), allocatable :: dz !< Nominal layer thicknesses integer :: interface_axes_id = 0 !< Vertical axes id for remapping at interfaces integer :: layer_axes_id = 0 !< Vertical axes id for remapping on layers @@ -271,15 +272,16 @@ function diag_remap_axes_configured(remap_cs) !! height or layer thicknesses changes. In the case of density-based !! coordinates then technically we should also regenerate the !! target grid whenever T/S change. -subroutine diag_remap_update(remap_cs, G, GV, US, 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(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - real, dimension(:, :, :), intent(in) :: h !< New thickness - real, dimension(:, :, :), intent(in) :: T !< New T - real, dimension(:, :, :), intent(in) :: S !< New S +subroutine diag_remap_update(remap_cs, G, GV, US, h, T, S, eqn_of_state, h_target) + type(diag_remap_ctrl), intent(inout) :: remap_cs !< Diagnostic coordinate control structure + type(ocean_grid_type), pointer :: G !< The ocean's grid type + type(verticalGrid_type), intent(in ) :: GV !< ocean vertical grid structure + type(unit_scale_type), intent(in ) :: US !< A dimensional unit scaling type + real, dimension(:, :, :), intent(in ) :: h !< Thicknesses used to construct new diagnostic grid + real, dimension(:, :, :), intent(in ) :: T !< Temperatures used to construct new diagnostic grid + real, dimension(:, :, :), intent(in ) :: S !< Salinity used to construct new diagnostic grid type(EOS_type), pointer :: eqn_of_state !< A pointer to the equation of state + real, dimension(:, :, :), intent(inout) :: h_target !< Where to store the new diagnostic array ! Local variables real, dimension(remap_cs%nz + 1) :: zInterfaces @@ -306,6 +308,7 @@ subroutine diag_remap_update(remap_cs, G, GV, US, h, T, S, eqn_of_state) call initialize_remapping(remap_cs%remap_cs, 'PPM_IH4', boundary_extrapolation=.false., & answers_2018=remap_cs%answers_2018) allocate(remap_cs%h(G%isd:G%ied,G%jsd:G%jed, nz)) + allocate(remap_cs%h_extensive(G%isd:G%ied,G%jsd:G%jed, nz)) remap_cs%initialized = .true. endif @@ -314,7 +317,7 @@ subroutine diag_remap_update(remap_cs, G, GV, US, h, T, S, eqn_of_state) ! assumption that h, T, S has changed. do j=G%jsc-1, G%jec+1 ; do i=G%isc-1, G%iec+1 if (G%mask2dT(i,j)==0.) then - remap_cs%h(i,j,:) = 0. + h_target(i,j,:) = 0. cycle endif @@ -338,7 +341,7 @@ subroutine diag_remap_update(remap_cs, G, GV, US, h, T, S, eqn_of_state) ! US%Z_to_m*G%bathyT(i,j), sum(h(i,j,:)), zInterfaces) call MOM_error(FATAL,"diag_remap_update: HYCOM1 coordinate not coded for diagnostics yet!") endif - remap_cs%h(i,j,:) = zInterfaces(1:nz) - zInterfaces(2:nz+1) + h_target(i,j,:) = zInterfaces(1:nz) - zInterfaces(2:nz+1) enddo ; enddo end subroutine diag_remap_update From 080fa2554462be9845bbc0df6fc87dc94e94e0f1 Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Fri, 6 Mar 2020 14:43:29 -0500 Subject: [PATCH 093/316] FMS and mkmf moved to deps directory Moving FMS and mkmf to the `build` directory led to conflicts in the `build/%/Makefile` and `build/%/path_names` rules, which were causing redundant builds. This patch moves these repositories back into a local `deps` directory, now kept inside of `.testing`. --- .testing/Makefile | 17 +++++++++-------- 1 file changed, 9 insertions(+), 8 deletions(-) diff --git a/.testing/Makefile b/.testing/Makefile index 0471499528..37dd36e1f1 100644 --- a/.testing/Makefile +++ b/.testing/Makefile @@ -9,17 +9,18 @@ DO_REPRO_TESTS ?= true #--- # Dependencies +DEPS = deps # mkmf, list_paths (GFDL build toolchain) MKMF_URL ?= https://github.com/NOAA-GFDL/mkmf.git MKMF_COMMIT ?= master -LIST_PATHS := $(abspath build/mkmf/bin/list_paths) -MKMF := $(abspath build/mkmf/bin/mkmf) +LIST_PATHS := $(abspath $(DEPS)/mkmf/bin/list_paths) +MKMF := $(abspath $(DEPS)/mkmf/bin/mkmf) # FMS framework FMS_URL ?= https://github.com/NOAA-GFDL/FMS.git FMS_COMMIT ?= f2e2c86f6c0eb6d389a20509a8a60fa22924e16b -FMS := build/fms +FMS := $(DEPS)/fms #--- # Build configuration @@ -85,7 +86,7 @@ SOURCE = \ MOM_SOURCE = $(call SOURCE,../src) $(wildcard ../config_src/solo_driver/*.F90) TARGET_SOURCE = $(call SOURCE,build/target_codebase/src) \ $(wildcard build/target_codebase/config_src/solo_driver/*.F90) -FMS_SOURCE = $(call SOURCE,build/fms/src) +FMS_SOURCE = $(call SOURCE,$(DEPS)/fms/src) #--- # Rules @@ -117,9 +118,9 @@ build/%/Makefile: build/%/path_names cp $(MKMF_TEMPLATE) $(@D) cd $(@D) && $(MKMF) \ -t $(notdir $(MKMF_TEMPLATE)) \ - -o '-I ../fms/build' \ + -o '-I ../../$(DEPS)/fms/build' \ -p MOM6 \ - -l '../fms/lib/libfms.a' \ + -l '../../$(DEPS)/fms/lib/libfms.a' \ -c $(MKMF_CPP) \ path_names @@ -173,8 +174,8 @@ $(FMS)/src: # Build Toolchain $(LIST_PATHS) $(MKMF): - git clone $(MKMF_URL) build/mkmf - cd build/mkmf; git checkout $(MKMF_COMMIT) + git clone $(MKMF_URL) $(DEPS)/mkmf + cd $(DEPS)/mkmf; git checkout $(MKMF_COMMIT) #---- From bfc2b6f5b9e5c1f00370e48fcb3d7f79c9ba7e0e Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Fri, 6 Mar 2020 14:45:50 -0500 Subject: [PATCH 094/316] Travis environment updated to bionic The Travis environment was updated in order to get a newer GCC compiler version. This was done to enable more aggressive initialization. --- .travis.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.travis.yml b/.travis.yml index 2cefbd8771..ac7cab1b14 100644 --- a/.travis.yml +++ b/.travis.yml @@ -3,7 +3,7 @@ # This is a not a c-language project but we use the same environment. language: c -dist: xenial +dist: bionic # --depth flag is breaking our merge, try disabling it # NOTE: We may be able to go back to depth=50 in production From 751616b6fc40c2f34507ba04bd5fa464879756e9 Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Fri, 6 Mar 2020 14:47:20 -0500 Subject: [PATCH 095/316] FMS version updated to 2019.01.01 tag The FMS version has been updated in order to permit more aggressive initialization settings in MOM6. This requires a few bugfixes in the newer FMS release. --- .testing/Makefile | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.testing/Makefile b/.testing/Makefile index 37dd36e1f1..1127677e00 100644 --- a/.testing/Makefile +++ b/.testing/Makefile @@ -19,7 +19,7 @@ MKMF := $(abspath $(DEPS)/mkmf/bin/mkmf) # FMS framework FMS_URL ?= https://github.com/NOAA-GFDL/FMS.git -FMS_COMMIT ?= f2e2c86f6c0eb6d389a20509a8a60fa22924e16b +FMS_COMMIT ?= 2019.01.01 FMS := $(DEPS)/fms #--- From 65b95e4e4b7969606e783d4fbc95139a6b02d834 Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Fri, 6 Mar 2020 15:51:04 -0500 Subject: [PATCH 096/316] Enable aggressive initialization Flags for initializing reals on stack as signaling NaNs (SNaN) and integers as 2**31 - 1 have been added in this build. --- .testing/Makefile | 8 ++++---- .testing/linux-ubuntu-xenial-gnu.mk | 8 +++++++- 2 files changed, 11 insertions(+), 5 deletions(-) diff --git a/.testing/Makefile b/.testing/Makefile index 1127677e00..8067e4218d 100644 --- a/.testing/Makefile +++ b/.testing/Makefile @@ -102,11 +102,11 @@ BUILD_TARGETS = MOM6 Makefile path_names # Conditionally build symmetric with coverage support COVFLAG=$(if $(REPORT_COVERAGE),COVERAGE=1,) -build/target/MOM6: MOMFLAGS=NETCDF=3 DEBUG=1 -build/symmetric/MOM6: MOMFLAGS=NETCDF=3 DEBUG=1 $(COVFLAG) -build/asymmetric/MOM6: MOMFLAGS=NETCDF=3 DEBUG=1 +build/target/MOM6: MOMFLAGS=NETCDF=3 DEBUG=1 INIT=1 +build/symmetric/MOM6: MOMFLAGS=NETCDF=3 DEBUG=1 INIT=1 $(COVFLAG) +build/asymmetric/MOM6: MOMFLAGS=NETCDF=3 DEBUG=1 INIT=1 build/repro/MOM6: MOMFLAGS=NETCDF=3 REPRO=1 -build/openmp/MOM6: MOMFLAGS=NETCDF=3 DEBUG=1 OPENMP=1 +build/openmp/MOM6: MOMFLAGS=NETCDF=3 DEBUG=1 OPENMP=1 INIT=1 build/asymmetric/path_names: GRID_SRC=config_src/dynamic build/%/path_names: GRID_SRC=config_src/dynamic_symmetric diff --git a/.testing/linux-ubuntu-xenial-gnu.mk b/.testing/linux-ubuntu-xenial-gnu.mk index 8c96c8c5c6..04ba952408 100644 --- a/.testing/linux-ubuntu-xenial-gnu.mk +++ b/.testing/linux-ubuntu-xenial-gnu.mk @@ -24,7 +24,7 @@ LD = mpif90 $(MAIN_PROGRAM) DEBUG = # If non-blank, perform a debug build (Cannot be # mixed with REPRO or TEST) -REPRO = # If non-blank, erform a build that guarentees +REPRO = # If non-blank, perform a build that guarentees # reprodicuibilty from run to run. Cannot be used # with DEBUG or TEST @@ -54,6 +54,8 @@ SSE = # The SSE options to be used to compile. If blank, COVERAGE = # Add the code coverage compile options. +INIT = # Enable aggressive initialization + # Need to use at least GNU Make version 3.81 need := 3.81 ok := $(filter $(need),$(firstword $(sort $(MAKE_VERSION) $(need)))) @@ -89,6 +91,10 @@ FFLAGS := -fcray-pointer -fdefault-double-8 -fdefault-real-8 -Waliasing -ffree-l FFLAGS_OPT = -O3 FFLAGS_REPRO = -O2 -fbounds-check FFLAGS_DEBUG = -O0 -g -W -Wno-compare-reals -fbounds-check -fbacktrace -ffpe-trap=invalid,zero,overflow +# Enable aggressive initialization +ifdef INIT +FFLAGS_DEBUG += -finit-real=snan -finit-integer=2147483647 -finit-derived +endif # Flags to add additional build options FFLAGS_OPENMP = -fopenmp From d09534a0659c407683d9380ec7450c328f41acbe Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Tue, 10 Mar 2020 15:18:57 -0400 Subject: [PATCH 097/316] Doxygen 1.8.17 documentation fixes This resolves several new issues raised by the current version of Doxygen (1.8.17). Primarily it addresses the stricter enforcement of grouping syntax, e.g. !>@{ ... !>@} The current code is somewhat inconsistent in its use of !!@{ vs !>@{ , and moreso in the closing token. This patch updates these to always lead with starting Doxygen comment tokens !> . Exposing these groups also revealed a few undocumented variables, which have been updated with minimal descriptions for now. Finally, one subroutine in MOM_horizontal_regridding was causing a segfault, so it had to be reworked to remove its grouping, so that individual indices now have descriptions. --- config_src/solo_driver/MOM_surface_forcing.F90 | 2 +- src/ALE/regrid_interp.F90 | 2 +- src/core/MOM.F90 | 5 +++-- src/core/MOM_CoriolisAdv.F90 | 9 +++++---- src/core/MOM_PressureForce_Montgomery.F90 | 2 +- src/core/MOM_barotropic.F90 | 16 ++++++++-------- src/core/MOM_boundary_update.F90 | 2 +- src/core/MOM_continuity_PPM.F90 | 4 ++-- src/core/MOM_dynamics_split_RK2.F90 | 4 ++-- src/core/MOM_dynamics_unsplit.F90 | 4 ++-- src/core/MOM_dynamics_unsplit_RK2.F90 | 4 ++-- src/core/MOM_forcing_type.F90 | 2 +- src/diagnostics/MOM_diagnostics.F90 | 8 +++++--- src/equation_of_state/MOM_EOS_NEMO.F90 | 2 +- src/equation_of_state/MOM_EOS_UNESCO.F90 | 2 +- src/equation_of_state/MOM_EOS_Wright.F90 | 2 +- src/framework/MOM_diag_mediator.F90 | 15 ++++++++------- src/framework/MOM_file_parser.F90 | 2 +- src/framework/MOM_horizontal_regridding.F90 | 8 ++++---- src/framework/MOM_restart.F90 | 2 +- src/ice_shelf/MOM_ice_shelf_dynamics.F90 | 2 +- src/ocean_data_assim/MOM_oda_driver.F90 | 2 +- src/parameterizations/lateral/MOM_MEKE.F90 | 2 +- src/parameterizations/lateral/MOM_hor_visc.F90 | 2 +- .../lateral/MOM_internal_tides.F90 | 4 ++-- src/parameterizations/vertical/MOM_CVMix_KPP.F90 | 2 +- .../vertical/MOM_CVMix_conv.F90 | 2 +- .../vertical/MOM_CVMix_ddiff.F90 | 2 +- .../vertical/MOM_CVMix_shear.F90 | 2 +- .../vertical/MOM_bulk_mixed_layer.F90 | 4 ++-- .../vertical/MOM_diabatic_aux.F90 | 2 +- .../vertical/MOM_diabatic_driver.F90 | 5 +++-- .../vertical/MOM_diapyc_energy_req.F90 | 2 +- .../vertical/MOM_energetic_PBL.F90 | 6 +++--- .../vertical/MOM_internal_tide_input.F90 | 2 +- .../vertical/MOM_kappa_shear.F90 | 2 +- src/parameterizations/vertical/MOM_opacity.F90 | 4 ++-- .../vertical/MOM_regularize_layers.F90 | 4 ++-- .../vertical/MOM_set_diffusivity.F90 | 4 ++-- .../vertical/MOM_set_viscosity.F90 | 2 +- .../vertical/MOM_tidal_mixing.F90 | 6 +++--- src/tracer/MOM_OCMIP2_CFC.F90 | 8 ++++---- src/tracer/MOM_offline_main.F90 | 2 +- src/tracer/MOM_tracer_advect.F90 | 2 +- src/tracer/MOM_tracer_flow_control.F90 | 2 +- src/tracer/MOM_tracer_hor_diff.F90 | 4 ++-- src/tracer/MOM_tracer_registry.F90 | 2 +- src/user/MOM_controlled_forcing.F90 | 2 +- src/user/MOM_wave_interface.F90 | 4 ++-- 49 files changed, 96 insertions(+), 90 deletions(-) diff --git a/config_src/solo_driver/MOM_surface_forcing.F90 b/config_src/solo_driver/MOM_surface_forcing.F90 index 7fded7796e..df403712f7 100644 --- a/config_src/solo_driver/MOM_surface_forcing.F90 +++ b/config_src/solo_driver/MOM_surface_forcing.F90 @@ -207,7 +207,7 @@ module MOM_surface_forcing type(Neverland_surface_forcing_CS), pointer :: Neverland_forcing_CSp => NULL() type(idealized_hurricane_CS), pointer :: idealized_hurricane_CSp => NULL() type(SCM_CVmix_tests_CS), pointer :: SCM_CVmix_tests_CSp => NULL() - !!@} + !>@} end type surface_forcing_CS diff --git a/src/ALE/regrid_interp.F90 b/src/ALE/regrid_interp.F90 index 3faa5f46b1..19082292be 100644 --- a/src/ALE/regrid_interp.F90 +++ b/src/ALE/regrid_interp.F90 @@ -54,7 +54,7 @@ module regrid_interp !>@{ Interpolant degrees integer, parameter :: DEGREE_1 = 1, DEGREE_2 = 2, DEGREE_3 = 3, DEGREE_4 = 4 integer, public, parameter :: DEGREE_MAX = 5 -!!@} +!>@} !> When the N-R algorithm produces an estimate that lies outside [0,1], the !! estimate is set to be equal to the boundary location, 0 or 1, plus or minus diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index adb916298f..49c650fe62 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -143,7 +143,8 @@ module MOM !> A structure with diagnostic IDs of the state variables type MOM_diag_IDs !>@{ 3-d state field diagnostic IDs - integer :: id_u = -1, id_v = -1, id_h = -1 !!@} + integer :: id_u = -1, id_v = -1, id_h = -1 + !>@} !> 2-d state field diagnotic ID integer :: id_ssh_inst = -1 end type MOM_diag_IDs @@ -389,7 +390,7 @@ module MOM integer :: id_clock_ALE integer :: id_clock_other integer :: id_clock_offline_tracer -!!@} +!>@} contains diff --git a/src/core/MOM_CoriolisAdv.F90 b/src/core/MOM_CoriolisAdv.F90 index e044ea5f6d..2f96839ed5 100644 --- a/src/core/MOM_CoriolisAdv.F90 +++ b/src/core/MOM_CoriolisAdv.F90 @@ -73,7 +73,8 @@ module MOM_CoriolisAdv type(diag_ctrl), pointer :: diag !< A structure that is used to regulate the timing of diagnostic output. !>@{ Diagnostic IDs integer :: id_rv = -1, id_PV = -1, id_gKEu = -1, id_gKEv = -1 - integer :: id_rvxu = -1, id_rvxv = -1 !!@} + integer :: id_rvxu = -1, id_rvxv = -1 + !>@} end type CoriolisAdv_CS !>@{ Enumeration values for Coriolis_Scheme @@ -89,7 +90,7 @@ module MOM_CoriolisAdv character*(20), parameter :: SADOURNY75_ENSTRO_STRING = "SADOURNY75_ENSTRO" character*(20), parameter :: ARAKAWA_LAMB_STRING = "ARAKAWA_LAMB81" character*(20), parameter :: AL_BLEND_STRING = "ARAKAWA_LAMB_BLEND" -!!@} +!>@} !>@{ Enumeration values for KE_Scheme integer, parameter :: KE_ARAKAWA = 10 integer, parameter :: KE_SIMPLE_GUDONOV = 11 @@ -97,13 +98,13 @@ module MOM_CoriolisAdv character*(20), parameter :: KE_ARAKAWA_STRING = "KE_ARAKAWA" character*(20), parameter :: KE_SIMPLE_GUDONOV_STRING = "KE_SIMPLE_GUDONOV" character*(20), parameter :: KE_GUDONOV_STRING = "KE_GUDONOV" -!!@} +!>@} !>@{ Enumeration values for PV_Adv_Scheme integer, parameter :: PV_ADV_CENTERED = 21 integer, parameter :: PV_ADV_UPWIND1 = 22 character*(20), parameter :: PV_ADV_CENTERED_STRING = "PV_ADV_CENTERED" character*(20), parameter :: PV_ADV_UPWIND1_STRING = "PV_ADV_UPWIND1" -!!@} +!>@} contains diff --git a/src/core/MOM_PressureForce_Montgomery.F90 b/src/core/MOM_PressureForce_Montgomery.F90 index 5737999426..c8662cba15 100644 --- a/src/core/MOM_PressureForce_Montgomery.F90 +++ b/src/core/MOM_PressureForce_Montgomery.F90 @@ -46,7 +46,7 @@ module MOM_PressureForce_Mont !! deriving from density gradients within layers [L T-2 ~> m s-2]. !>@{ Diagnostic IDs integer :: id_PFu_bc = -1, id_PFv_bc = -1, id_e_tidal = -1 - !!@} + !>@} type(tidal_forcing_CS), pointer :: tides_CSp => NULL() !< The tidal forcing control structure end type PressureForce_Mont_CS diff --git a/src/core/MOM_barotropic.F90 b/src/core/MOM_barotropic.F90 index 0ccf4d8f3b..00f6f3cd3e 100644 --- a/src/core/MOM_barotropic.F90 +++ b/src/core/MOM_barotropic.F90 @@ -86,7 +86,7 @@ module MOM_barotropic !>@{ Index ranges for the open boundary conditions integer :: is_u_obc, ie_u_obc, js_u_obc, je_u_obc integer :: is_v_obc, ie_v_obc, js_v_obc, je_v_obc - !!@} + !>@} logical :: is_alloced = .false. !< True if BT_OBC is in use and has been allocated type(group_pass_type) :: pass_uv !< Structure for group halo pass @@ -273,10 +273,10 @@ module MOM_barotropic type(time_type), pointer :: Time => NULL() !< A pointer to the ocean models 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(MOM_domain_type), pointer :: BT_Domain => NULL() !< Barotropic MOM domain 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. + type(tidal_forcing_CS), pointer :: tides_CSp => NULL() !< Control structure for tides + logical :: module_is_initialized = .false. !< If true, module has been initialized integer :: isdw !< The lower i-memory limit for the wide halo arrays. integer :: iedw !< The upper i-memory limit for the wide halo arrays. @@ -312,7 +312,7 @@ module MOM_barotropic integer :: id_BTC_FA_v_NN = -1, id_BTC_FA_v_N0 = -1, id_BTC_FA_v_S0 = -1, id_BTC_FA_v_SS = -1 integer :: id_BTC_vbt_NN = -1, id_BTC_vbt_SS = -1 integer :: id_uhbt0 = -1, id_vhbt0 = -1 - !!@} + !>@} end type barotropic_CS @@ -360,14 +360,14 @@ module MOM_barotropic type, private :: memory_size_type !>@{ Currently active memory limits integer :: isdw, iedw, jsdw, jedw ! The memory limits of the wide halo arrays. - !!@} + !>@} end type memory_size_type !>@{ CPU time clock IDs integer :: id_clock_sync=-1, id_clock_calc=-1 integer :: id_clock_calc_pre=-1, id_clock_calc_post=-1 integer :: id_clock_pass_step=-1, id_clock_pass_pre=-1, id_clock_pass_post=-1 -!!@} +!>@} !>@{ Enumeration values for various schemes integer, parameter :: HARMONIC = 1 @@ -379,7 +379,7 @@ module MOM_barotropic character*(20), parameter :: HARMONIC_STRING = "HARMONIC" character*(20), parameter :: ARITHMETIC_STRING = "ARITHMETIC" character*(20), parameter :: BT_CONT_STRING = "FROM_BT_CONT" -!!@} +!>@} contains diff --git a/src/core/MOM_boundary_update.F90 b/src/core/MOM_boundary_update.F90 index c3ed3c705b..4dc89efeb0 100644 --- a/src/core/MOM_boundary_update.F90 +++ b/src/core/MOM_boundary_update.F90 @@ -46,7 +46,7 @@ module MOM_boundary_update type(tidal_bay_OBC_CS), pointer :: tidal_bay_OBC_CSp => NULL() type(shelfwave_OBC_CS), pointer :: shelfwave_OBC_CSp => NULL() type(dyed_channel_OBC_CS), pointer :: dyed_channel_OBC_CSp => NULL() - !!@} + !>@} end type update_OBC_CS integer :: id_clock_pass !< A CPU time clock ID diff --git a/src/core/MOM_continuity_PPM.F90 b/src/core/MOM_continuity_PPM.F90 index eeaa3d8687..c594d31494 100644 --- a/src/core/MOM_continuity_PPM.F90 +++ b/src/core/MOM_continuity_PPM.F90 @@ -22,7 +22,7 @@ module MOM_continuity_PPM !>@{ CPU time clock IDs integer :: id_clock_update, id_clock_correct -!!@} +!>@} !> Control structure for mom_continuity_ppm type, public :: continuity_PPM_CS ; private @@ -66,7 +66,7 @@ module MOM_continuity_PPM type :: loop_bounds_type ; private !>@{ Loop bounds integer :: ish, ieh, jsh, jeh - !!@} + !>@} end type loop_bounds_type contains diff --git a/src/core/MOM_dynamics_split_RK2.F90 b/src/core/MOM_dynamics_split_RK2.F90 index 005f73af11..f4327c2d57 100644 --- a/src/core/MOM_dynamics_split_RK2.F90 +++ b/src/core/MOM_dynamics_split_RK2.F90 @@ -163,7 +163,7 @@ module MOM_dynamics_split_RK2 ! Split scheme only. integer :: id_uav = -1, id_vav = -1 integer :: id_u_BT_accel = -1, id_v_BT_accel = -1 - !!@} + !>@} type(diag_ctrl), pointer :: diag !< A structure that is used to regulate the !! timing of diagnostic output. @@ -227,7 +227,7 @@ module MOM_dynamics_split_RK2 integer :: id_clock_continuity, id_clock_thick_diff integer :: id_clock_btstep, id_clock_btcalc, id_clock_btforce integer :: id_clock_pass, id_clock_pass_init -!!@} +!>@} contains diff --git a/src/core/MOM_dynamics_unsplit.F90 b/src/core/MOM_dynamics_unsplit.F90 index 4030d0f2da..a5671948b1 100644 --- a/src/core/MOM_dynamics_unsplit.F90 +++ b/src/core/MOM_dynamics_unsplit.F90 @@ -127,7 +127,7 @@ module MOM_dynamics_unsplit !>@{ Diagnostic IDs integer :: id_uh = -1, id_vh = -1 integer :: id_PFu = -1, id_PFv = -1, id_CAu = -1, id_CAv = -1 - !!@} + !>@} type(diag_ctrl), pointer :: diag => NULL() !< A structure that is used to !! regulate the timing of diagnostic output. @@ -174,7 +174,7 @@ module MOM_dynamics_unsplit integer :: id_clock_Cor, id_clock_pres, id_clock_vertvisc integer :: id_clock_continuity, id_clock_horvisc, id_clock_mom_update integer :: id_clock_pass, id_clock_pass_init -!!@} +!>@} contains diff --git a/src/core/MOM_dynamics_unsplit_RK2.F90 b/src/core/MOM_dynamics_unsplit_RK2.F90 index 7700507301..e88b7c32dc 100644 --- a/src/core/MOM_dynamics_unsplit_RK2.F90 +++ b/src/core/MOM_dynamics_unsplit_RK2.F90 @@ -130,7 +130,7 @@ module MOM_dynamics_unsplit_RK2 !>@{ Diagnostic IDs integer :: id_uh = -1, id_vh = -1 integer :: id_PFu = -1, id_PFv = -1, id_CAu = -1, id_CAv = -1 - !!@} + !>@} type(diag_ctrl), pointer :: diag => NULL() !< A structure that is used to !! regulate the timing of diagnostic output. @@ -178,7 +178,7 @@ module MOM_dynamics_unsplit_RK2 integer :: id_clock_Cor, id_clock_pres, id_clock_vertvisc integer :: id_clock_horvisc, id_clock_continuity, id_clock_mom_update integer :: id_clock_pass, id_clock_pass_init -!!@} +!>@} contains diff --git a/src/core/MOM_forcing_type.F90 b/src/core/MOM_forcing_type.F90 index 3f2ac0f1b9..98d55d2146 100644 --- a/src/core/MOM_forcing_type.F90 +++ b/src/core/MOM_forcing_type.F90 @@ -327,7 +327,7 @@ module MOM_forcing_type ! Iceberg + Ice shelf diagnostic handles integer :: id_ustar_ice_cover = -1 integer :: id_frac_ice_cover = -1 - !!@} + !>@} integer :: id_clock_forcing = -1 !< CPU clock id diff --git a/src/diagnostics/MOM_diagnostics.F90 b/src/diagnostics/MOM_diagnostics.F90 index 09a51fac3c..284322f072 100644 --- a/src/diagnostics/MOM_diagnostics.F90 +++ b/src/diagnostics/MOM_diagnostics.F90 @@ -134,7 +134,8 @@ module MOM_diagnostics integer :: id_pbo = -1 integer :: id_thkcello = -1, id_rhoinsitu = -1 integer :: id_rhopot0 = -1, id_rhopot2 = -1 - integer :: id_h_pre_sync = -1 !!@} + integer :: id_h_pre_sync = -1 + !>@} !> The control structure for calculating wave speed. type(wave_speed_CS), pointer :: wave_speed_CSp => NULL() @@ -168,7 +169,7 @@ module MOM_diagnostics integer :: id_salt_deficit = -1 integer :: id_Heat_PmE = -1 integer :: id_intern_heat = -1 - !!@} + !>@} end type surface_diag_IDs @@ -177,7 +178,8 @@ module MOM_diagnostics !>@{ Diagnostics for tracer horizontal transport integer :: id_uhtr = -1, id_umo = -1, id_umo_2d = -1 integer :: id_vhtr = -1, id_vmo = -1, id_vmo_2d = -1 - integer :: id_dynamics_h = -1, id_dynamics_h_tendency = -1 !!@} + integer :: id_dynamics_h = -1, id_dynamics_h_tendency = -1 + !>@} end type transport_diag_IDs diff --git a/src/equation_of_state/MOM_EOS_NEMO.F90 b/src/equation_of_state/MOM_EOS_NEMO.F90 index 97ed9f8540..68488881bb 100644 --- a/src/equation_of_state/MOM_EOS_NEMO.F90 +++ b/src/equation_of_state/MOM_EOS_NEMO.F90 @@ -169,7 +169,7 @@ module MOM_EOS_NEMO real, parameter :: BET102 = 6.2255521644e-02 real, parameter :: BET012 = -2.6514181169e-03 real, parameter :: BET003 = -2.3025968587e-04 -!!@} +!>@} contains diff --git a/src/equation_of_state/MOM_EOS_UNESCO.F90 b/src/equation_of_state/MOM_EOS_UNESCO.F90 index c7dbad3b66..a296cfc382 100644 --- a/src/equation_of_state/MOM_EOS_UNESCO.F90 +++ b/src/equation_of_state/MOM_EOS_UNESCO.F90 @@ -49,7 +49,7 @@ module MOM_EOS_UNESCO 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 -!!@} +!>@} contains diff --git a/src/equation_of_state/MOM_EOS_Wright.F90 b/src/equation_of_state/MOM_EOS_Wright.F90 index 8d29e08f92..bc490ca361 100644 --- a/src/equation_of_state/MOM_EOS_Wright.F90 +++ b/src/equation_of_state/MOM_EOS_Wright.F90 @@ -69,7 +69,7 @@ module MOM_EOS_Wright real, parameter :: b3 = 2.084372e2, b4 = 5.944068e5, b5 = -9.643486e3 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 diff --git a/src/framework/MOM_diag_mediator.F90 b/src/framework/MOM_diag_mediator.F90 index 1fc012b7b9..421c23cf68 100644 --- a/src/framework/MOM_diag_mediator.F90 +++ b/src/framework/MOM_diag_mediator.F90 @@ -216,7 +216,7 @@ module MOM_diag_mediator type(axes_grp) :: axesB1, axesT1, axesCu1, axesCv1 type(axes_grp), dimension(:), allocatable :: remap_axesTL, remap_axesBL, remap_axesCuL, remap_axesCvL type(axes_grp), dimension(:), allocatable :: remap_axesTi, remap_axesBi, remap_axesCui, remap_axesCvi - !!@} + !>@} real, dimension(:,:), pointer :: mask2dT => null() !< 2D mask array for cell-center points real, dimension(:,:), pointer :: mask2dBu => null() !< 2D mask array for cell-corner points @@ -231,7 +231,7 @@ module MOM_diag_mediator real, dimension(:,:,:), pointer :: mask3dBi => null() real, dimension(:,:,:), pointer :: mask3dCui => null() real, dimension(:,:,:), pointer :: mask3dCvi => null() - !!@} + !>@} end type diagcs_dsamp !> The following data type a list of diagnostic fields an their variants, @@ -264,7 +264,7 @@ module MOM_diag_mediator type(axes_grp) :: axesBL, axesTL, axesCuL, axesCvL type(axes_grp) :: axesBi, axesTi, axesCui, axesCvi type(axes_grp) :: axesB1, axesT1, axesCu1, axesCv1 - !!@} + !>@} type(axes_grp) :: axesZi !< A 1-D z-space axis at interfaces type(axes_grp) :: axesZL !< A 1-D z-space axis at layer centers type(axes_grp) :: axesNull !< An axis group for scalars @@ -285,7 +285,7 @@ module MOM_diag_mediator type(diagcs_dsamp), dimension(2:MAX_DSAMP_LEV) :: dsamp !< Downsample control container - !!@} + !>@} ! Space for diagnostics is dynamically allocated as it is needed. ! The chunk size is how much the array should grow on each new allocation. @@ -306,10 +306,10 @@ module MOM_diag_mediator type(axes_grp), dimension(:), allocatable :: & remap_axesZL, & !< The 1-D z-space cell-centered axis for remapping remap_axesZi !< The 1-D z-space interface axis for remapping - !!@{ + !>@{ Axes used for remapping type(axes_grp), dimension(:), allocatable :: remap_axesTL, remap_axesBL, remap_axesCuL, remap_axesCvL type(axes_grp), dimension(:), allocatable :: remap_axesTi, remap_axesBi, remap_axesCui, remap_axesCvi - !!@} + !>@} ! Pointer to H, G and T&S needed for remapping real, dimension(:,:,:), pointer :: h => null() !< The thicknesses needed for remapping @@ -334,8 +334,9 @@ module MOM_diag_mediator end type diag_ctrl -! CPU clocks +!>@{ CPU clocks integer :: id_clock_diag_mediator, id_clock_diag_remap, id_clock_diag_grid_updates +!>@} contains diff --git a/src/framework/MOM_file_parser.F90 b/src/framework/MOM_file_parser.F90 index 4746a36f9e..00ed8152c9 100644 --- a/src/framework/MOM_file_parser.F90 +++ b/src/framework/MOM_file_parser.F90 @@ -29,7 +29,7 @@ module MOM_file_parser logical, parameter :: log_to_stdout_default = .false. logical, parameter :: complete_doc_default = .true. logical, parameter :: minimal_doc_default = .true. -!!@} +!>@} !> The valid lines extracted from an input parameter file without comments type, private :: file_data_type ; private diff --git a/src/framework/MOM_horizontal_regridding.F90 b/src/framework/MOM_horizontal_regridding.F90 index a6cd8c048a..7c19d715db 100644 --- a/src/framework/MOM_horizontal_regridding.F90 +++ b/src/framework/MOM_horizontal_regridding.F90 @@ -60,10 +60,10 @@ module MOM_horizontal_regridding subroutine myStats(array, missing, is, ie, js, je, k, mesg) real, dimension(:,:), intent(in) :: array !< input array (ND) real, intent(in) :: missing !< missing value (ND) - !!@{ - !> Horizontal loop bounds to calculate statistics for - integer :: is,ie,js,je - !!@} + integer :: is !< Start index in i + integer :: ie !< End index in i + integer :: js !< Start index in j + integer :: je !< End index in j integer :: k !< Level to calculate statistics for character(len=*) :: mesg !< Label to use in message ! Local variables diff --git a/src/framework/MOM_restart.F90 b/src/framework/MOM_restart.F90 index c3819fc865..ec9789c20b 100644 --- a/src/framework/MOM_restart.F90 +++ b/src/framework/MOM_restart.F90 @@ -99,7 +99,7 @@ module MOM_restart type(p2d), pointer :: var_ptr2d(:) => NULL() type(p3d), pointer :: var_ptr3d(:) => NULL() type(p4d), pointer :: var_ptr4d(:) => NULL() - !!@} + !>@} integer :: max_fields !< The maximum number of restart fields end type MOM_restart_CS diff --git a/src/ice_shelf/MOM_ice_shelf_dynamics.F90 b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 index 80f2d8f60f..928221d276 100644 --- a/src/ice_shelf/MOM_ice_shelf_dynamics.F90 +++ b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 @@ -151,7 +151,7 @@ module MOM_ice_shelf_dynamics 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 diff --git a/src/ocean_data_assim/MOM_oda_driver.F90 b/src/ocean_data_assim/MOM_oda_driver.F90 index 74afd4868a..089e1fc422 100644 --- a/src/ocean_data_assim/MOM_oda_driver.F90 +++ b/src/ocean_data_assim/MOM_oda_driver.F90 @@ -106,7 +106,7 @@ module MOM_oda_driver_mod !>@{ DA parameters integer, parameter :: NO_ASSIM = 0, OI_ASSIM=1, EAKF_ASSIM=2 -!!@} +!>@} contains diff --git a/src/parameterizations/lateral/MOM_MEKE.F90 b/src/parameterizations/lateral/MOM_MEKE.F90 index f8ee166a03..4c4effc0bd 100644 --- a/src/parameterizations/lateral/MOM_MEKE.F90 +++ b/src/parameterizations/lateral/MOM_MEKE.F90 @@ -87,7 +87,7 @@ module MOM_MEKE integer :: id_KhMEKE_u = -1, id_KhMEKE_v = -1, id_Ku = -1, id_Au = -1 integer :: id_Le = -1, id_gamma_b = -1, id_gamma_t = -1 integer :: id_Lrhines = -1, id_Leady = -1 - !!@} + !>@} ! Infrastructure integer :: id_clock_pass !< Clock for group pass calls diff --git a/src/parameterizations/lateral/MOM_hor_visc.F90 b/src/parameterizations/lateral/MOM_hor_visc.F90 index c818603366..a5c6dc4be8 100644 --- a/src/parameterizations/lateral/MOM_hor_visc.F90 +++ b/src/parameterizations/lateral/MOM_hor_visc.F90 @@ -183,7 +183,7 @@ module MOM_hor_visc integer :: id_vort_xy_q = -1, id_div_xx_h = -1 integer :: id_FrictWork = -1, id_FrictWorkIntz = -1 integer :: id_FrictWork_GME = -1 - !!@} + !>@} end type hor_visc_CS diff --git a/src/parameterizations/lateral/MOM_internal_tides.F90 b/src/parameterizations/lateral/MOM_internal_tides.F90 index efa82206a4..0d76b10c03 100644 --- a/src/parameterizations/lateral/MOM_internal_tides.F90 +++ b/src/parameterizations/lateral/MOM_internal_tides.F90 @@ -134,7 +134,7 @@ module MOM_internal_tides integer, allocatable, dimension(:,:) :: & id_En_ang_mode, & id_itidal_loss_ang_mode - !!@} + !>@} end type int_tide_CS @@ -142,7 +142,7 @@ module MOM_internal_tides type :: loop_bounds_type ; private !>@{ The active loop bounds integer :: ish, ieh, jsh, jeh - !!@} + !>@} end type loop_bounds_type contains diff --git a/src/parameterizations/vertical/MOM_CVMix_KPP.F90 b/src/parameterizations/vertical/MOM_CVMix_KPP.F90 index f5ee25c743..cebae1da97 100644 --- a/src/parameterizations/vertical/MOM_CVMix_KPP.F90 +++ b/src/parameterizations/vertical/MOM_CVMix_KPP.F90 @@ -140,7 +140,7 @@ module MOM_CVMix_KPP integer :: id_EnhW = -1 integer :: id_La_SL = -1 integer :: id_OBLdepth_original = -1 - !!@} + !>@} ! Diagnostics arrays real, allocatable, dimension(:,:) :: OBLdepth !< Depth (positive) of OBL [m] diff --git a/src/parameterizations/vertical/MOM_CVMix_conv.F90 b/src/parameterizations/vertical/MOM_CVMix_conv.F90 index 19a71116f3..ce6a40dad2 100644 --- a/src/parameterizations/vertical/MOM_CVMix_conv.F90 +++ b/src/parameterizations/vertical/MOM_CVMix_conv.F90 @@ -38,7 +38,7 @@ module MOM_CVMix_conv type(diag_ctrl), pointer :: diag => NULL() !< Pointer to diagnostics control structure !>@{ Diagnostics handles integer :: id_N2 = -1, id_kd_conv = -1, id_kv_conv = -1 - !!@} + !>@} ! Diagnostics arrays real, allocatable, dimension(:,:,:) :: N2 !< Squared Brunt-Vaisala frequency [s-2] diff --git a/src/parameterizations/vertical/MOM_CVMix_ddiff.F90 b/src/parameterizations/vertical/MOM_CVMix_ddiff.F90 index 57400e31bf..8ebcbd88a9 100644 --- a/src/parameterizations/vertical/MOM_CVMix_ddiff.F90 +++ b/src/parameterizations/vertical/MOM_CVMix_ddiff.F90 @@ -44,7 +44,7 @@ module MOM_CVMix_ddiff type(diag_ctrl), pointer :: diag => NULL() !< Pointer to diagnostics control structure !>@{ Diagnostics handles 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 [Z2 s-1 ~> m2 s-1] diff --git a/src/parameterizations/vertical/MOM_CVMix_shear.F90 b/src/parameterizations/vertical/MOM_CVMix_shear.F90 index 68081a97d9..6aa01d50e5 100644 --- a/src/parameterizations/vertical/MOM_CVMix_shear.F90 +++ b/src/parameterizations/vertical/MOM_CVMix_shear.F90 @@ -47,7 +47,7 @@ module MOM_CVMix_shear !>@{ Diagnostic handles 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 diff --git a/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 b/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 index 8286251f0b..00686c2bbe 100644 --- a/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 +++ b/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 @@ -146,13 +146,13 @@ module MOM_bulk_mixed_layer integer :: id_TKE_mech_decay = -1, id_TKE_conv_decay = -1, id_TKE_conv_s2 = -1 integer :: id_PE_detrain = -1, id_PE_detrain2 = -1, id_h_mismatch = -1 integer :: id_Hsfc_used = -1, id_Hsfc_max = -1, id_Hsfc_min = -1 - !!@} + !>@} end type bulkmixedlayer_CS !>@{ CPU clock IDs integer :: id_clock_detrain=0, id_clock_mech=0, id_clock_conv=0, id_clock_adjustment=0 integer :: id_clock_EOS=0, id_clock_resort=0, id_clock_pass=0 -!!@} +!>@} contains diff --git a/src/parameterizations/vertical/MOM_diabatic_aux.F90 b/src/parameterizations/vertical/MOM_diabatic_aux.F90 index 923b2b4899..343423a221 100644 --- a/src/parameterizations/vertical/MOM_diabatic_aux.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_aux.F90 @@ -92,7 +92,7 @@ module MOM_diabatic_aux !>@{ CPU time clock IDs integer :: id_clock_uv_at_h, id_clock_frazil -!!@} +!>@} contains diff --git a/src/parameterizations/vertical/MOM_diabatic_driver.F90 b/src/parameterizations/vertical/MOM_diabatic_driver.F90 index fb8b05c9e1..e6537a58b1 100644 --- a/src/parameterizations/vertical/MOM_diabatic_driver.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_driver.F90 @@ -203,7 +203,7 @@ module MOM_diabatic_driver integer :: id_frazil_temp_tend = -1 integer :: id_frazil_heat_tend = -1 integer :: id_frazil_heat_tend_2d = -1 - !!@} + !>@} logical :: diabatic_diff_tendency_diag = .false. !< If true calculate diffusive tendency diagnostics logical :: boundary_forcing_tendency_diag = .false. !< If true calculate frazil diagnostics @@ -244,11 +244,12 @@ module MOM_diabatic_driver type(time_type), pointer :: Time !< Pointer to model time (needed for sponges) end type diabatic_CS -! clock ids +!>@{ clock ids integer :: id_clock_entrain, id_clock_mixedlayer, id_clock_set_diffusivity integer :: id_clock_tracers, id_clock_tridiag, id_clock_pass, id_clock_sponge integer :: id_clock_geothermal, id_clock_differential_diff, id_clock_remap integer :: id_clock_kpp +!>@} contains diff --git a/src/parameterizations/vertical/MOM_diapyc_energy_req.F90 b/src/parameterizations/vertical/MOM_diapyc_energy_req.F90 index e9c5e6a3d0..32b6feeded 100644 --- a/src/parameterizations/vertical/MOM_diapyc_energy_req.F90 +++ b/src/parameterizations/vertical/MOM_diapyc_energy_req.F90 @@ -39,7 +39,7 @@ module MOM_diapyc_energy_req integer :: id_CHCt=-1, id_CHCb=-1, id_CHCc=-1, id_CHCh=-1 integer :: id_T0=-1, id_Tf=-1, id_S0=-1, id_Sf=-1, id_N2_0=-1, id_N2_f=-1 integer :: id_h=-1, id_zInt=-1 - !!@} + !>@} end type diapyc_energy_req_CS contains diff --git a/src/parameterizations/vertical/MOM_energetic_PBL.F90 b/src/parameterizations/vertical/MOM_energetic_PBL.F90 index b4fad24a60..ce2ea912d7 100644 --- a/src/parameterizations/vertical/MOM_energetic_PBL.F90 +++ b/src/parameterizations/vertical/MOM_energetic_PBL.F90 @@ -190,7 +190,7 @@ module MOM_energetic_PBL integer :: id_TKE_mech_decay = -1, id_TKE_conv_decay = -1 integer :: id_Mixing_Length = -1, id_Velocity_Scale = -1 integer :: id_MSTAR_mix = -1, id_LA_mod = -1, id_LA = -1, id_MSTAR_LT = -1 - !!@} + !>@} end type energetic_PBL_CS !>@{ Enumeration values for mstar_Scheme @@ -215,14 +215,14 @@ module MOM_energetic_PBL character*(20), parameter :: NONE_STRING = "NONE" character*(20), parameter :: RESCALED_STRING = "RESCALE" character*(20), parameter :: ADDITIVE_STRING = "ADDITIVE" -!!@} +!>@} !> A type for conveniently passing around ePBL diagnostics for a column. type, public :: ePBL_column_diags ; private !>@{ Local column copies of energy change diagnostics, all in [R Z3 T-3 ~> W m-2]. real :: dTKE_conv, dTKE_forcing, dTKE_wind, dTKE_mixing real :: dTKE_MKE, dTKE_mech_decay, dTKE_conv_decay - !!@} + !>@} real :: LA !< The value of the Langmuir number [nondim] real :: LAmod !< The modified Langmuir number by convection [nondim] real :: mstar !< The value of mstar used in ePBL [nondim] diff --git a/src/parameterizations/vertical/MOM_internal_tide_input.F90 b/src/parameterizations/vertical/MOM_internal_tide_input.F90 index 8d31f19825..ebd5016855 100644 --- a/src/parameterizations/vertical/MOM_internal_tide_input.F90 +++ b/src/parameterizations/vertical/MOM_internal_tide_input.F90 @@ -56,7 +56,7 @@ module MOM_int_tide_input !>@{ Diagnostic IDs integer :: id_TKE_itidal = -1, id_Nb = -1, id_N2_bot = -1 - !!@} + !>@} end type int_tide_input_CS !> This type is used to exchange fields related to the internal tides. diff --git a/src/parameterizations/vertical/MOM_kappa_shear.F90 b/src/parameterizations/vertical/MOM_kappa_shear.F90 index b6eba22e14..77407b6da1 100644 --- a/src/parameterizations/vertical/MOM_kappa_shear.F90 +++ b/src/parameterizations/vertical/MOM_kappa_shear.F90 @@ -94,7 +94,7 @@ module MOM_kappa_shear !! regulate the timing of diagnostic output. !>@{ Diagnostic IDs integer :: id_Kd_shear = -1, id_TKE = -1, id_ILd2 = -1, id_dz_Int = -1 - !!@} + !>@} end type Kappa_shear_CS ! integer :: id_clock_project, id_clock_KQ, id_clock_avg, id_clock_setup diff --git a/src/parameterizations/vertical/MOM_opacity.F90 b/src/parameterizations/vertical/MOM_opacity.F90 index 5ebeed6af6..8e4acf1142 100644 --- a/src/parameterizations/vertical/MOM_opacity.F90 +++ b/src/parameterizations/vertical/MOM_opacity.F90 @@ -70,12 +70,12 @@ module MOM_opacity !>@{ Diagnostic IDs integer :: id_sw_pen = -1, id_sw_vis_pen = -1 integer, pointer :: id_opacity(:) => NULL() - !!@} + !>@} end type opacity_CS !>@{ Coded integers to specify the opacity scheme integer, parameter :: NO_SCHEME = 0, MANIZZA_05 = 1, MOREL_88 = 2, SINGLE_EXP = 3, DOUBLE_EXP = 4 -!!@} +!>@} character*(10), parameter :: MANIZZA_05_STRING = "MANIZZA_05" !< String to specify the opacity scheme character*(10), parameter :: MOREL_88_STRING = "MOREL_88" !< String to specify the opacity scheme diff --git a/src/parameterizations/vertical/MOM_regularize_layers.F90 b/src/parameterizations/vertical/MOM_regularize_layers.F90 index d044f09b8a..a4a4723092 100644 --- a/src/parameterizations/vertical/MOM_regularize_layers.F90 +++ b/src/parameterizations/vertical/MOM_regularize_layers.F90 @@ -68,14 +68,14 @@ module MOM_regularize_layers integer :: id_def_rat_v_2 = -1, id_def_rat_v_2b = -1 integer :: id_def_rat_u_3 = -1, id_def_rat_u_3b = -1 integer :: id_def_rat_v_3 = -1, id_def_rat_v_3b = -1 - !!@} + !>@} #endif end type regularize_layers_CS !>@{ Clock IDs !! \todo Should these be global? integer :: id_clock_pass, id_clock_EOS -!!@} +!>@} contains diff --git a/src/parameterizations/vertical/MOM_set_diffusivity.F90 b/src/parameterizations/vertical/MOM_set_diffusivity.F90 index 5ee82aa7ca..06b7f0f2a5 100644 --- a/src/parameterizations/vertical/MOM_set_diffusivity.F90 +++ b/src/parameterizations/vertical/MOM_set_diffusivity.F90 @@ -164,7 +164,7 @@ module MOM_set_diffusivity integer :: id_maxTKE = -1, id_TKE_to_Kd = -1, id_Kd_user = -1 integer :: id_Kd_layer = -1, id_Kd_BBL = -1, id_N2 = -1 integer :: id_Kd_Work = -1, id_KT_extra = -1, id_KS_extra = -1 - !!@} + !>@} end type set_diffusivity_CS @@ -187,7 +187,7 @@ module MOM_set_diffusivity !>@{ CPU time clocks integer :: id_clock_kappaShear, id_clock_CVMix_ddiff -!!@} +!>@} contains diff --git a/src/parameterizations/vertical/MOM_set_viscosity.F90 b/src/parameterizations/vertical/MOM_set_viscosity.F90 index 7019a3e379..840059e25a 100644 --- a/src/parameterizations/vertical/MOM_set_viscosity.F90 +++ b/src/parameterizations/vertical/MOM_set_viscosity.F90 @@ -102,7 +102,7 @@ module MOM_set_visc integer :: id_bbl_thick_v = -1, id_kv_bbl_v = -1, id_bbl_v = -1 integer :: id_Ray_u = -1, id_Ray_v = -1 integer :: id_nkml_visc_u = -1, id_nkml_visc_v = -1 - !!@} + !>@} end type set_visc_CS contains diff --git a/src/parameterizations/vertical/MOM_tidal_mixing.F90 b/src/parameterizations/vertical/MOM_tidal_mixing.F90 index 2ea4a95d7d..510a20f552 100644 --- a/src/parameterizations/vertical/MOM_tidal_mixing.F90 +++ b/src/parameterizations/vertical/MOM_tidal_mixing.F90 @@ -191,11 +191,11 @@ module MOM_tidal_mixing integer :: id_Schmittner_coeff = -1 integer :: id_tidal_qe_md = -1 integer :: id_vert_dep = -1 - !!@} + !>@} end type tidal_mixing_cs -!!@{ Coded parmameters for specifying mixing schemes +!>@{ Coded parmameters for specifying mixing schemes character*(20), parameter :: STLAURENT_PROFILE_STRING = "STLAURENT_02" character*(20), parameter :: POLZIN_PROFILE_STRING = "POLZIN_09" integer, parameter :: STLAURENT_02 = 1 @@ -204,7 +204,7 @@ module MOM_tidal_mixing character*(20), parameter :: SCHMITTNER_SCHEME_STRING = "SCHMITTNER" integer, parameter :: SIMMONS = 1 integer, parameter :: SCHMITTNER = 2 -!!@} +!>@} contains diff --git a/src/tracer/MOM_OCMIP2_CFC.F90 b/src/tracer/MOM_OCMIP2_CFC.F90 index 3aa250b8bb..a95ea654f4 100644 --- a/src/tracer/MOM_OCMIP2_CFC.F90 +++ b/src/tracer/MOM_OCMIP2_CFC.F90 @@ -61,7 +61,7 @@ module MOM_OCMIP2_CFC real :: e1_11, e1_12 ! Coefficients for calculating CFC11 and CFC12 solubilities [PSU-1] real :: e2_11, e2_12 ! Coefficients for calculating CFC11 and CFC12 solubilities [PSU-1 hectoKelvin-1] real :: e3_11, e3_12 ! Coefficients for calculating CFC11 and CFC12 solubilities [PSU-2 hectoKelvin-2] - !!@} + !>@} real :: CFC11_IC_val = 0.0 !< The initial value assigned to CFC11 [mol m-3]. real :: CFC12_IC_val = 0.0 !< The initial value assigned to CFC12 [mol m-3]. real :: CFC11_land_val = -1.0 !< The value of CFC11 used where land is masked out [mol m-3]. @@ -76,9 +76,9 @@ module MOM_OCMIP2_CFC integer :: ind_cfc_12_flux !< Index returned by aof_set_coupler_flux that is used to !! pack and unpack surface boundary condition arrays. - type(diag_ctrl), pointer :: diag => NULL() ! A structure that is used to - ! regulate the timing of diagnostic output. - type(MOM_restart_CS), pointer :: restart_CSp => NULL() + type(diag_ctrl), pointer :: diag => NULL() !< A structure that is used to regulate + !! the timing of diagnostic output. + type(MOM_restart_CS), pointer :: restart_CSp => NULL() !< Model restart control structure ! The following vardesc types contain a package of metadata about each tracer. type(vardesc) :: CFC11_desc !< A set of metadata for the CFC11 tracer diff --git a/src/tracer/MOM_offline_main.F90 b/src/tracer/MOM_offline_main.F90 index 3dd5a9ab2b..dfdcb4c09b 100644 --- a/src/tracer/MOM_offline_main.F90 +++ b/src/tracer/MOM_offline_main.F90 @@ -150,7 +150,7 @@ module MOM_offline_main id_temp_regrid = -1, & id_salt_regrid = -1, & id_h_regrid = -1 - !!@} + !>@} ! IDs for timings of various offline components integer :: id_clock_read_fields = -1 !< A CPU time clock diff --git a/src/tracer/MOM_tracer_advect.F90 b/src/tracer/MOM_tracer_advect.F90 index e425629c77..4cfaaf806a 100644 --- a/src/tracer/MOM_tracer_advect.F90 +++ b/src/tracer/MOM_tracer_advect.F90 @@ -41,7 +41,7 @@ module MOM_tracer_advect integer :: id_clock_advect integer :: id_clock_pass integer :: id_clock_sync -!!@} +!>@} contains diff --git a/src/tracer/MOM_tracer_flow_control.F90 b/src/tracer/MOM_tracer_flow_control.F90 index 716745093c..6e28477d26 100644 --- a/src/tracer/MOM_tracer_flow_control.F90 +++ b/src/tracer/MOM_tracer_flow_control.F90 @@ -102,7 +102,7 @@ module MOM_tracer_flow_control type(pseudo_salt_tracer_CS), pointer :: pseudo_salt_tracer_CSp => NULL() type(boundary_impulse_tracer_CS), pointer :: boundary_impulse_tracer_CSp => NULL() type(dyed_obc_tracer_CS), pointer :: dyed_obc_tracer_CSp => NULL() - !!@} + !>@} end type tracer_flow_control_CS contains diff --git a/src/tracer/MOM_tracer_hor_diff.F90 b/src/tracer/MOM_tracer_hor_diff.F90 index 2d42483c49..d15431d02e 100644 --- a/src/tracer/MOM_tracer_hor_diff.F90 +++ b/src/tracer/MOM_tracer_hor_diff.F90 @@ -71,7 +71,7 @@ module MOM_tracer_hor_diff integer :: id_CFL = -1 integer :: id_khdt_x = -1 integer :: id_khdt_y = -1 - !!@} + !>@} type(group_pass_type) :: pass_t !< For group halo pass, used in both !! tracer_hordiff and tracer_epipycnal_ML_diff @@ -88,7 +88,7 @@ module MOM_tracer_hor_diff !>@{ CPU time clocks integer :: id_clock_diffuse, id_clock_epimix, id_clock_pass, id_clock_sync -!!@} +!>@} contains diff --git a/src/tracer/MOM_tracer_registry.F90 b/src/tracer/MOM_tracer_registry.F90 index 01d15fb887..f6d51926bd 100644 --- a/src/tracer/MOM_tracer_registry.F90 +++ b/src/tracer/MOM_tracer_registry.F90 @@ -116,7 +116,7 @@ module MOM_tracer_registry integer :: id_remap_conc = -1, id_remap_cont = -1, id_remap_cont_2d = -1 integer :: id_tendency = -1, id_trxh_tendency = -1, id_trxh_tendency_2d = -1 integer :: id_tr_vardec = -1 - !!@} + !>@} end type tracer_type !> Type to carry basic tracer information diff --git a/src/user/MOM_controlled_forcing.F90 b/src/user/MOM_controlled_forcing.F90 index cbfce62f39..277c0423aa 100644 --- a/src/user/MOM_controlled_forcing.F90 +++ b/src/user/MOM_controlled_forcing.F90 @@ -68,7 +68,7 @@ module MOM_controlled_forcing avg_SST_anom => NULL(), & avg_SSS_anom => NULL(), & avg_SSS => NULL() - !!@} + !>@} type(diag_ctrl), pointer :: diag => NULL() !< A structure that is used to !! regulate the timing of diagnostic output. integer :: id_heat_0 = -1 !< Diagnostic handle diff --git a/src/user/MOM_wave_interface.F90 b/src/user/MOM_wave_interface.F90 index e7361bf13c..815e4fa361 100644 --- a/src/user/MOM_wave_interface.F90 +++ b/src/user/MOM_wave_interface.F90 @@ -122,7 +122,7 @@ module MOM_wave_interface integer, public :: id_surfacestokes_x = -1 , id_surfacestokes_y = -1 integer, public :: id_3dstokes_x = -1 , id_3dstokes_y = -1 integer, public :: id_La_turb = -1 - !!@} + !>@} end type wave_parameters_CS @@ -184,7 +184,7 @@ module MOM_wave_interface logical :: StaticWaves, DHH85_Is_Set real :: WaveAge, WaveWind real :: PI -!!@} +!>@} contains From b3ea6023060d570ba4b89b5a0a1d8ef2763797fa Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Tue, 10 Mar 2020 21:16:54 +0000 Subject: [PATCH 098/316] Fix "no lib" builds - The new FMS has test_ programs that are found by list_paths which do not build properly unless using the FMS Makefile.am method. - The "no libs" test was added to detect namespace collisions that are hidden when building with libraries. For now we'll retain this test but to do so requires a one-line hack to edit the pathnames file. --- .gitlab-ci.yml | 2 ++ 1 file changed, 2 insertions(+) diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index e5af9feb36..39b63c8f85 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -63,6 +63,7 @@ gnu:ocean-only-nolibs: - 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 + - sed -i '/FMS\/.*\/test_/d' path_names - ../../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) @@ -75,6 +76,7 @@ gnu:ice-ocean-nolibs: - 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_param,land_null,atmos_null} + - sed -i '/FMS\/.*\/test_/d' path_names - ../../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) From 9abcb103658921e65873ee2cedb15f668694e9a4 Mon Sep 17 00:00:00 2001 From: Andrew Shao Date: Wed, 11 Mar 2020 14:51:20 -0400 Subject: [PATCH 099/316] Set target diagnostic grid based on boolean The target grid for the diagnostic grid update is now based on a assigning a differrent pointer based on the boolean input argument 'intensive'. This is done so that this update is done in a more 'object-oriented' way --- src/framework/MOM_diag_mediator.F90 | 4 ++-- src/framework/MOM_diag_remap.F90 | 12 ++++++++++-- 2 files changed, 12 insertions(+), 4 deletions(-) diff --git a/src/framework/MOM_diag_mediator.F90 b/src/framework/MOM_diag_mediator.F90 index a7fe44a93a..e6efe12b1b 100644 --- a/src/framework/MOM_diag_mediator.F90 +++ b/src/framework/MOM_diag_mediator.F90 @@ -3250,13 +3250,13 @@ subroutine diag_update_remap_grids(diag_cs, alt_h, alt_T, alt_S, update_intensiv if (update_intensive_local) then do i=1, diag_cs%num_diag_coords call diag_remap_update(diag_cs%diag_remap_cs(i), diag_cs%G, diag_cs%GV, diag_cs%US, h_diag, T_diag, S_diag, & - diag_cs%eqn_of_state, diag_cs%diag_remap_cs(i)%h) + diag_cs%eqn_of_state, intensive=.true.) enddo endif if (update_extensive_local) then do i=1, diag_cs%num_diag_coords call diag_remap_update(diag_cs%diag_remap_cs(i), diag_cs%G, diag_cs%GV, diag_cs%US, h_diag, T_diag, S_diag, & - diag_cs%eqn_of_state, diag_cs%diag_remap_cs(i)%h_extensive) + diag_cs%eqn_of_state, intensive=.false.) enddo endif diff --git a/src/framework/MOM_diag_remap.F90 b/src/framework/MOM_diag_remap.F90 index 81e7187786..914a815387 100644 --- a/src/framework/MOM_diag_remap.F90 +++ b/src/framework/MOM_diag_remap.F90 @@ -272,7 +272,7 @@ function diag_remap_axes_configured(remap_cs) !! height or layer thicknesses changes. In the case of density-based !! coordinates then technically we should also regenerate the !! target grid whenever T/S change. -subroutine diag_remap_update(remap_cs, G, GV, US, h, T, S, eqn_of_state, h_target) +subroutine diag_remap_update(remap_cs, G, GV, US, h, T, S, eqn_of_state, intensive) type(diag_remap_ctrl), intent(inout) :: remap_cs !< Diagnostic coordinate control structure type(ocean_grid_type), pointer :: G !< The ocean's grid type type(verticalGrid_type), intent(in ) :: GV !< ocean vertical grid structure @@ -281,7 +281,9 @@ subroutine diag_remap_update(remap_cs, G, GV, US, h, T, S, eqn_of_state, h_targe real, dimension(:, :, :), intent(in ) :: T !< Temperatures used to construct new diagnostic grid real, dimension(:, :, :), intent(in ) :: S !< Salinity used to construct new diagnostic grid type(EOS_type), pointer :: eqn_of_state !< A pointer to the equation of state - real, dimension(:, :, :), intent(inout) :: h_target !< Where to store the new diagnostic array + logical, intent(in ) :: intensive !< If true, update the intensive diagnostic array + + real, dimension(:,:,:), pointer :: h_target !< Where to store the new diagnostic array ! Local variables real, dimension(remap_cs%nz + 1) :: zInterfaces @@ -312,6 +314,12 @@ subroutine diag_remap_update(remap_cs, G, GV, US, h, T, S, eqn_of_state, h_targe remap_cs%initialized = .true. endif + if (intensive) then + h_target => remap_cs%h + else + h_target => reamp_cs%h_extensive + endif + ! Calculate remapping thicknesses for different target grids based on ! nominal/target interface locations. This happens for every call on the ! assumption that h, T, S has changed. From 3477bbe45e123e5e889680491049a1c0cb1afcf7 Mon Sep 17 00:00:00 2001 From: Andrew Shao Date: Wed, 11 Mar 2020 15:01:29 -0400 Subject: [PATCH 100/316] Revert "Set target diagnostic grid based on boolean" This reverts commit 9abcb103658921e65873ee2cedb15f668694e9a4. --- src/framework/MOM_diag_mediator.F90 | 4 ++-- src/framework/MOM_diag_remap.F90 | 12 ++---------- 2 files changed, 4 insertions(+), 12 deletions(-) diff --git a/src/framework/MOM_diag_mediator.F90 b/src/framework/MOM_diag_mediator.F90 index e6efe12b1b..a7fe44a93a 100644 --- a/src/framework/MOM_diag_mediator.F90 +++ b/src/framework/MOM_diag_mediator.F90 @@ -3250,13 +3250,13 @@ subroutine diag_update_remap_grids(diag_cs, alt_h, alt_T, alt_S, update_intensiv if (update_intensive_local) then do i=1, diag_cs%num_diag_coords call diag_remap_update(diag_cs%diag_remap_cs(i), diag_cs%G, diag_cs%GV, diag_cs%US, h_diag, T_diag, S_diag, & - diag_cs%eqn_of_state, intensive=.true.) + diag_cs%eqn_of_state, diag_cs%diag_remap_cs(i)%h) enddo endif if (update_extensive_local) then do i=1, diag_cs%num_diag_coords call diag_remap_update(diag_cs%diag_remap_cs(i), diag_cs%G, diag_cs%GV, diag_cs%US, h_diag, T_diag, S_diag, & - diag_cs%eqn_of_state, intensive=.false.) + diag_cs%eqn_of_state, diag_cs%diag_remap_cs(i)%h_extensive) enddo endif diff --git a/src/framework/MOM_diag_remap.F90 b/src/framework/MOM_diag_remap.F90 index 914a815387..81e7187786 100644 --- a/src/framework/MOM_diag_remap.F90 +++ b/src/framework/MOM_diag_remap.F90 @@ -272,7 +272,7 @@ function diag_remap_axes_configured(remap_cs) !! height or layer thicknesses changes. In the case of density-based !! coordinates then technically we should also regenerate the !! target grid whenever T/S change. -subroutine diag_remap_update(remap_cs, G, GV, US, h, T, S, eqn_of_state, intensive) +subroutine diag_remap_update(remap_cs, G, GV, US, h, T, S, eqn_of_state, h_target) type(diag_remap_ctrl), intent(inout) :: remap_cs !< Diagnostic coordinate control structure type(ocean_grid_type), pointer :: G !< The ocean's grid type type(verticalGrid_type), intent(in ) :: GV !< ocean vertical grid structure @@ -281,9 +281,7 @@ subroutine diag_remap_update(remap_cs, G, GV, US, h, T, S, eqn_of_state, intensi real, dimension(:, :, :), intent(in ) :: T !< Temperatures used to construct new diagnostic grid real, dimension(:, :, :), intent(in ) :: S !< Salinity used to construct new diagnostic grid type(EOS_type), pointer :: eqn_of_state !< A pointer to the equation of state - logical, intent(in ) :: intensive !< If true, update the intensive diagnostic array - - real, dimension(:,:,:), pointer :: h_target !< Where to store the new diagnostic array + real, dimension(:, :, :), intent(inout) :: h_target !< Where to store the new diagnostic array ! Local variables real, dimension(remap_cs%nz + 1) :: zInterfaces @@ -314,12 +312,6 @@ subroutine diag_remap_update(remap_cs, G, GV, US, h, T, S, eqn_of_state, intensi remap_cs%initialized = .true. endif - if (intensive) then - h_target => remap_cs%h - else - h_target => reamp_cs%h_extensive - endif - ! Calculate remapping thicknesses for different target grids based on ! nominal/target interface locations. This happens for every call on the ! assumption that h, T, S has changed. From 46ce21ec7d4c7e8f7fe65906cbfa43c654b4f22e Mon Sep 17 00:00:00 2001 From: Andrew Shao Date: Fri, 13 Mar 2020 10:59:59 -0700 Subject: [PATCH 101/316] Store h_extensive for both native and remapped coordinates The model thicknesses --- src/framework/MOM_diag_mediator.F90 | 5 +++++ src/framework/MOM_diag_remap.F90 | 13 +++++++------ 2 files changed, 12 insertions(+), 6 deletions(-) diff --git a/src/framework/MOM_diag_mediator.F90 b/src/framework/MOM_diag_mediator.F90 index e6efe12b1b..b4b4d9162d 100644 --- a/src/framework/MOM_diag_mediator.F90 +++ b/src/framework/MOM_diag_mediator.F90 @@ -332,6 +332,8 @@ module MOM_diag_mediator !> Number of checksum-only diagnostics integer :: num_chksum_diags + real, dimension(:,:,:), allocatable :: h_begin + end type diag_ctrl ! CPU clocks @@ -1504,6 +1506,7 @@ subroutine post_data_3d(diag_field_id, field, diag_cs, is_static, mask, alt_h) allocate(remapped_field(size(field,1), size(field,2), diag%axes%nz)) call vertically_reintegrate_diag_field( & diag_cs%diag_remap_cs(diag%axes%vertical_coordinate_number), diag_cs%G, & + diag_cs%h_extensive, diag_cs%diag_remap_cs(diag%axes%vertical_coordinate_number)%h_extensive, & staggered_in_x, staggered_in_y, diag%axes%mask3d, diag_cs%missing_value, & field, remapped_field) @@ -3066,6 +3069,7 @@ subroutine diag_mediator_init(G, GV, US, nz, param_file, diag_cs, doc_file_dir) diag_cs%S => null() diag_cs%eqn_of_state => null() + allocate(diag_cs%h_begin(G%isd:G%ied,G%jsd:G%jed,nz)) #if defined(DEBUG) || defined(__DO_SAFETY_CHECKS__) allocate(diag_cs%h_old(G%isd:G%ied,G%jsd:G%jed,nz)) diag_cs%h_old(:,:,:) = 0.0 @@ -3254,6 +3258,7 @@ subroutine diag_update_remap_grids(diag_cs, alt_h, alt_T, alt_S, update_intensiv enddo endif if (update_extensive_local) then + CS%h_begin(:,:,:) = CS%h(:,:,:) do i=1, diag_cs%num_diag_coords call diag_remap_update(diag_cs%diag_remap_cs(i), diag_cs%G, diag_cs%GV, diag_cs%US, h_diag, T_diag, S_diag, & diag_cs%eqn_of_state, intensive=.false.) diff --git a/src/framework/MOM_diag_remap.F90 b/src/framework/MOM_diag_remap.F90 index 914a815387..8839c1df70 100644 --- a/src/framework/MOM_diag_remap.F90 +++ b/src/framework/MOM_diag_remap.F90 @@ -317,7 +317,7 @@ subroutine diag_remap_update(remap_cs, G, GV, US, h, T, S, eqn_of_state, intensi if (intensive) then h_target => remap_cs%h else - h_target => reamp_cs%h_extensive + h_target => remap_cs%h_extensive endif ! Calculate remapping thicknesses for different target grids based on @@ -495,11 +495,12 @@ subroutine diag_remap_calc_hmask(remap_cs, G, mask) end subroutine diag_remap_calc_hmask !> Vertically re-grid an already vertically-integrated diagnostic field to alternative vertical grid. -subroutine vertically_reintegrate_diag_field(remap_cs, G, h, staggered_in_x, staggered_in_y, & +subroutine vertically_reintegrate_diag_field(remap_cs, G, h, h_dest, staggered_in_x, staggered_in_y, & mask, missing_value, field, reintegrated_field) type(diag_remap_ctrl), intent(in) :: remap_cs !< Diagnostic coodinate control structure type(ocean_grid_type), intent(in) :: G !< Ocean grid structure - real, dimension(:,:,:), intent(in) :: h !< The current thicknesses + real, dimension(:,:,:), intent(in) :: h !< The thicknesses of the source grid + real, dimension(:,:,:), intent(in) :: h_target !< The thicknesses of the target grid logical, intent(in) :: staggered_in_x !< True is the x-axis location is at u or q points logical, intent(in) :: staggered_in_y !< True is the y-axis location is at v or q points real, dimension(:,:,:), pointer :: mask !< A mask for the field @@ -536,7 +537,7 @@ subroutine vertically_reintegrate_diag_field(remap_cs, G, h, staggered_in_x, sta if (mask(I,j,1) == 0.) cycle endif h_src(:) = 0.5 * (h(i_lo,j,:) + h(i_hi,j,:)) - h_dest(:) = 0.5 * (remap_cs%h(i_lo,j,:) + remap_cs%h(i_hi,j,:)) + h_dest(:) = 0.5 * (h_target(i_lo,j,:) + h_target(i_hi,j,:)) call reintegrate_column(nz_src, h_src, field(I1,j,:), & nz_dest, h_dest, 0., reintegrated_field(I1,j,:)) enddo @@ -551,7 +552,7 @@ subroutine vertically_reintegrate_diag_field(remap_cs, G, h, staggered_in_x, sta if (mask(i,J,1) == 0.) cycle endif h_src(:) = 0.5 * (h(i,j_lo,:) + h(i,j_hi,:)) - h_dest(:) = 0.5 * (remap_cs%h(i,j_lo,:) + remap_cs%h(i,j_hi,:)) + h_dest(:) = 0.5 * (h_target(i,j_lo,:) + h_target(i,j_hi,:)) call reintegrate_column(nz_src, h_src, field(i,J1,:), & nz_dest, h_dest, 0., reintegrated_field(i,J1,:)) enddo @@ -564,7 +565,7 @@ subroutine vertically_reintegrate_diag_field(remap_cs, G, h, staggered_in_x, sta if (mask(i,j,1) == 0.) cycle endif h_src(:) = h(i,j,:) - h_dest(:) = remap_cs%h(i,j,:) + h_dest(:) = h_target(i,j,:) call reintegrate_column(nz_src, h_src, field(i,j,:), & nz_dest, h_dest, 0., reintegrated_field(i,j,:)) enddo From e8d47dc58b05ac3123f433671f9f775514c4780c Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Mon, 16 Mar 2020 13:51:23 -0400 Subject: [PATCH 102/316] +Corrected diagnostics and diagnostic units Corrected the units reported for 9 diagnostics, and altered the code so that the diagnostics N2_u and N2_v are only offered if the can be calculated and the proper diagnostics are written if these diagnostics are requested (previously arrays of zeros were always output). All solutions are bitwise identical, but some diagostics in output files change and the available_diags files have altered entries. --- .../lateral/MOM_lateral_mixing_coeffs.F90 | 36 +++++++++---------- .../vertical/MOM_energetic_PBL.F90 | 15 ++++---- 2 files changed, 24 insertions(+), 27 deletions(-) diff --git a/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 b/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 index a25b810846..45c7f267fb 100644 --- a/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 +++ b/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 @@ -85,9 +85,6 @@ module MOM_lateral_mixing_coeffs real, dimension(:,:,:), pointer :: & slope_x => NULL(), & !< Zonal isopycnal slope [nondim] slope_y => NULL(), & !< Meridional isopycnal slope [nondim] - !### These are posted as diagnostics but are never set. - N2_u => NULL(), & !< Brunt-Vaisala frequency at u-points [s-2] - N2_v => NULL(), & !< Brunt-Vaisala frequency at v-points [s-2] ebt_struct => NULL() !< Vertical structure function to scale diffusivities with [nondim] real ALLOCABLE_, dimension(NIMEMB_PTR_,NJMEM_) :: & Laplac3_const_u !< Laplacian metric-dependent constants [L3 ~> m3] @@ -422,14 +419,14 @@ subroutine calc_slope_functions(h, tv, dt, G, GV, US, CS) endif if (query_averaging_enabled(CS%diag)) then - if (CS%id_SN_u > 0) call post_data(CS%id_SN_u, CS%SN_u, CS%diag) - if (CS%id_SN_v > 0) call post_data(CS%id_SN_v, CS%SN_v, CS%diag) - if (CS%id_L2u > 0) call post_data(CS%id_L2u, CS%L2u, CS%diag) - if (CS%id_L2v > 0) call post_data(CS%id_L2v, CS%L2v, CS%diag) - !### I do not believe that CS%N2_u and CS%N2_v are ever set, but because the contents - ! of CS are public, they might be set somewhere outside of this module. - if (CS%id_N2_u > 0) call post_data(CS%id_N2_u, CS%N2_u, CS%diag) - if (CS%id_N2_v > 0) call post_data(CS%id_N2_v, CS%N2_v, CS%diag) + if (CS%id_SN_u > 0) call post_data(CS%id_SN_u, CS%SN_u, CS%diag) + if (CS%id_SN_v > 0) call post_data(CS%id_SN_v, CS%SN_v, CS%diag) + if (CS%id_L2u > 0) call post_data(CS%id_L2u, CS%L2u, CS%diag) + if (CS%id_L2v > 0) call post_data(CS%id_L2v, CS%L2v, CS%diag) + if (CS%calculate_Eady_growth_rate .and. CS%use_stored_slopes) then + if (CS%id_N2_u > 0) call post_data(CS%id_N2_u, N2_u, CS%diag) + if (CS%id_N2_v > 0) call post_data(CS%id_N2_v, N2_v, CS%diag) + endif endif end subroutine calc_slope_functions @@ -992,8 +989,6 @@ subroutine VarMix_init(Time, G, GV, US, param_file, diag, CS) in_use = .true. allocate(CS%slope_x(IsdB:IedB,jsd:jed,G%ke+1)) ; CS%slope_x(:,:,:) = 0.0 allocate(CS%slope_y(isd:ied,JsdB:JedB,G%ke+1)) ; CS%slope_y(:,:,:) = 0.0 - allocate(CS%N2_u(IsdB:IedB,jsd:jed,G%ke+1)) ; CS%N2_u(:,:,:) = 0.0 - allocate(CS%N2_v(isd:ied,JsdB:JedB,G%ke+1)) ; CS%N2_v(:,:,:) = 0.0 call get_param(param_file, mdl, "KD_SMOOTH", CS%kappa_smooth, & "A diapycnal diffusivity that is used to interpolate "//& "more sensible values of T & S into thin layers.", & @@ -1041,16 +1036,19 @@ subroutine VarMix_init(Time, G, GV, US, param_file, diag, CS) 'm2', conversion=US%L_to_m**2) endif - if (CS%use_stored_slopes) then + if (CS%calculate_Eady_growth_rate .and. CS%use_stored_slopes) then CS%id_N2_u = register_diag_field('ocean_model', 'N2_u', diag%axesCui, Time, & - 'Square of Brunt-Vaisala frequency, N^2, at u-points, as used in Visbeck et al.', 's-2') + 'Square of Brunt-Vaisala frequency, N^2, at u-points, as used in Visbeck et al.', & + 's-2', conversion=US%s_to_T**2) CS%id_N2_v = register_diag_field('ocean_model', 'N2_v', diag%axesCvi, Time, & - 'Square of Brunt-Vaisala frequency, N^2, at v-points, as used in Visbeck et al.', 's-2') - !### The units of the next two diagnostics should be 'nondim'. + 'Square of Brunt-Vaisala frequency, N^2, at v-points, as used in Visbeck et al.', & + 's-2', conversion=US%s_to_T**2) + endif + if (CS%use_stored_slopes) then CS%id_S2_u = register_diag_field('ocean_model', 'S2_u', diag%axesCu1, Time, & - 'Depth average square of slope magnitude, S^2, at u-points, as used in Visbeck et al.', 's-2') + 'Depth average square of slope magnitude, S^2, at u-points, as used in Visbeck et al.', 'nondim') CS%id_S2_v = register_diag_field('ocean_model', 'S2_v', diag%axesCv1, Time, & - 'Depth average square of slope magnitude, S^2, at v-points, as used in Visbeck et al.', 's-2') + 'Depth average square of slope magnitude, S^2, at v-points, as used in Visbeck et al.', 'nondim') endif oneOrTwo = 1.0 diff --git a/src/parameterizations/vertical/MOM_energetic_PBL.F90 b/src/parameterizations/vertical/MOM_energetic_PBL.F90 index ce2ea912d7..483934e38f 100644 --- a/src/parameterizations/vertical/MOM_energetic_PBL.F90 +++ b/src/parameterizations/vertical/MOM_energetic_PBL.F90 @@ -2303,25 +2303,24 @@ subroutine energetic_PBL_init(Time, G, GV, US, param_file, diag, CS) !/ Checking output flags - !### Most of these units are wrong and should be W m-2 CS%id_ML_depth = register_diag_field('ocean_model', 'ePBL_h_ML', diag%axesT1, & Time, 'Surface boundary layer depth', 'm', conversion=US%Z_to_m, & cmor_long_name='Ocean Mixed Layer Thickness Defined by Mixing Scheme') CS%id_TKE_wind = register_diag_field('ocean_model', 'ePBL_TKE_wind', diag%axesT1, & - Time, 'Wind-stirring source of mixed layer TKE', 'm3 s-3', conversion=US%RZ3_T3_to_W_m2) + Time, 'Wind-stirring source of mixed layer TKE', 'W m-2', conversion=US%RZ3_T3_to_W_m2) CS%id_TKE_MKE = register_diag_field('ocean_model', 'ePBL_TKE_MKE', diag%axesT1, & - Time, 'Mean kinetic energy source of mixed layer TKE', 'm3 s-3', conversion=US%RZ3_T3_to_W_m2) + Time, 'Mean kinetic energy source of mixed layer TKE', 'W m-2', conversion=US%RZ3_T3_to_W_m2) CS%id_TKE_conv = register_diag_field('ocean_model', 'ePBL_TKE_conv', diag%axesT1, & - Time, 'Convective source of mixed layer TKE', 'm3 s-3', conversion=US%RZ3_T3_to_W_m2) + Time, 'Convective source of mixed layer TKE', 'W m-2', conversion=US%RZ3_T3_to_W_m2) CS%id_TKE_forcing = register_diag_field('ocean_model', 'ePBL_TKE_forcing', diag%axesT1, & Time, 'TKE consumed by mixing surface forcing or penetrative shortwave radation '//& - 'through model layers', 'm3 s-3', conversion=US%RZ3_T3_to_W_m2) + 'through model layers', 'W m-2', conversion=US%RZ3_T3_to_W_m2) CS%id_TKE_mixing = register_diag_field('ocean_model', 'ePBL_TKE_mixing', diag%axesT1, & - Time, 'TKE consumed by mixing that deepens the mixed layer', 'm3 s-3', conversion=US%RZ3_T3_to_W_m2) + Time, 'TKE consumed by mixing that deepens the mixed layer', 'W m-2', conversion=US%RZ3_T3_to_W_m2) CS%id_TKE_mech_decay = register_diag_field('ocean_model', 'ePBL_TKE_mech_decay', diag%axesT1, & - Time, 'Mechanical energy decay sink of mixed layer TKE', 'm3 s-3', conversion=US%RZ3_T3_to_W_m2) + Time, 'Mechanical energy decay sink of mixed layer TKE', 'W m-2', conversion=US%RZ3_T3_to_W_m2) CS%id_TKE_conv_decay = register_diag_field('ocean_model', 'ePBL_TKE_conv_decay', diag%axesT1, & - Time, 'Convective energy decay sink of mixed layer TKE', 'm3 s-3', conversion=US%RZ3_T3_to_W_m2) + Time, 'Convective energy decay sink of mixed layer TKE', 'W m-2', conversion=US%RZ3_T3_to_W_m2) CS%id_Mixing_Length = register_diag_field('ocean_model', 'Mixing_Length', diag%axesTi, & Time, 'Mixing Length that is used', 'm', conversion=US%Z_to_m) CS%id_Velocity_Scale = register_diag_field('ocean_model', 'Velocity_Scale', diag%axesTi, & From 3c08cef2f7a6ca8abc0bd36cd40ceb07c377c15e Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Mon, 16 Mar 2020 17:23:32 -0400 Subject: [PATCH 103/316] +Corrected doc_param_time Rewrote the subroutine doc_param_time to work like the other doc_param routines, including making the units argument optional, removing the argument layout_param, and adding the new internally visible routine time_string. Because time variables are currently logged as real values using the timeunit argument to log_param_time, these changes do not have a widespread impact. All answers are bitwise identical, but there are some limited interface changes. --- src/framework/MOM_document.F90 | 83 ++++++++++++++++++++----------- src/framework/MOM_file_parser.F90 | 3 +- 2 files changed, 54 insertions(+), 32 deletions(-) diff --git a/src/framework/MOM_document.F90 b/src/framework/MOM_document.F90 index 75496544db..6c4c1f1ebb 100644 --- a/src/framework/MOM_document.F90 +++ b/src/framework/MOM_document.F90 @@ -4,7 +4,7 @@ module MOM_document ! This file is part of MOM6. See LICENSE.md for the license. -use MOM_time_manager, only : time_type +use MOM_time_manager, only : time_type, operator(==), get_time, get_ticks_per_second use MOM_error_handler, only : MOM_error, FATAL, WARNING, is_root_pe implicit none ; private @@ -104,9 +104,9 @@ subroutine doc_param_logical(doc, varname, desc, units, val, default, & if (doc%filesAreOpen) then if (val) then - mesg = define_string(doc,varname,STRING_TRUE,units) + mesg = define_string(doc, varname, STRING_TRUE, units) else - mesg = undef_string(doc,varname,units) + mesg = undef_string(doc, varname, units) endif equalsDefault = .false. @@ -156,7 +156,7 @@ subroutine doc_param_logical_array(doc, varname, desc, units, vals, default, & endif enddo - mesg = define_string(doc,varname,valstring,units) + mesg = define_string(doc, varname, valstring, units) equalsDefault = .false. if (present(default)) then @@ -197,7 +197,7 @@ subroutine doc_param_int(doc, varname, desc, units, val, default, & if (doc%filesAreOpen) then valstring = int_string(val) - mesg = define_string(doc,varname,valstring,units) + mesg = define_string(doc, varname, valstring, units) equalsDefault = .false. if (present(default)) then @@ -238,7 +238,7 @@ subroutine doc_param_int_array(doc, varname, desc, units, vals, default, & valstring = trim(valstring)//", "//trim(int_string(vals(i))) enddo - mesg = define_string(doc,varname,valstring,units) + mesg = define_string(doc, varname, valstring, units) equalsDefault = .false. if (present(default)) then @@ -274,7 +274,7 @@ subroutine doc_param_real(doc, varname, desc, units, val, default, debuggingPara if (doc%filesAreOpen) then valstring = real_string(val) - mesg = define_string(doc,varname,valstring,units) + mesg = define_string(doc, varname, valstring, units) equalsDefault = .false. if (present(default)) then @@ -283,8 +283,7 @@ subroutine doc_param_real(doc, varname, desc, units, val, default, debuggingPara endif if (mesgHasBeenDocumented(doc, varName, mesg)) return ! Avoid duplicates - call writeMessageAndDesc(doc, mesg, desc, equalsDefault, & - debuggingParam=debuggingParam) + call writeMessageAndDesc(doc, mesg, desc, equalsDefault, debuggingParam=debuggingParam) endif end subroutine doc_param_real @@ -310,7 +309,7 @@ subroutine doc_param_real_array(doc, varname, desc, units, vals, default, debugg if (doc%filesAreOpen) then valstring = trim(real_array_string(vals(:))) - mesg = define_string(doc,varname,valstring,units) + mesg = define_string(doc, varname, valstring, units) equalsDefault = .false. if (present(default)) then @@ -320,8 +319,7 @@ subroutine doc_param_real_array(doc, varname, desc, units, vals, default, debugg endif if (mesgHasBeenDocumented(doc, varName, mesg)) return ! Avoid duplicates - call writeMessageAndDesc(doc, mesg, desc, equalsDefault, & - debuggingParam=debuggingParam) + call writeMessageAndDesc(doc, mesg, desc, equalsDefault, debuggingParam=debuggingParam) endif end subroutine doc_param_real_array @@ -347,7 +345,7 @@ subroutine doc_param_char(doc, varname, desc, units, val, default, & call open_doc_file(doc) if (doc%filesAreOpen) then - mesg = define_string(doc,varname,'"'//trim(val)//'"',units) + mesg = define_string(doc, varname, '"'//trim(val)//'"', units) equalsDefault = .false. if (present(default)) then @@ -414,35 +412,40 @@ subroutine doc_closeBlock(doc, blockName) 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) +subroutine doc_param_time(doc, varname, desc, val, default, units, 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. + character(len=*), optional, intent(in) :: units !< The units of the parameter being documented 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 - character(len=mLen) :: mesg - logical :: equalsDefault + + ! Local varables + character(len=mLen) :: mesg ! The output message + character(len=doc%commentColumn) :: valstring ! A string with the formatted value. + logical :: equalsDefault ! True if val = default. if (.not. (is_root_pe() .and. associated(doc))) return call open_doc_file(doc) - equalsDefault = .false. if (doc%filesAreOpen) then - numspc = max(1,doc%commentColumn-18-len_trim(varname)) - mesg = "#define "//trim(varname)//" Time-type"//repeat(" ",numspc)//"!" - if (len_trim(units) > 0) mesg = trim(mesg)//" ["//trim(units)//"]" + valstring = time_string(val) + if (present(units)) then + mesg = define_string(doc, varname, valstring, units) + else + mesg = define_string(doc, varname, valstring, "[days : seconds]") + endif + + equalsDefault = .false. + if (present(default)) then + if (val == default) equalsDefault = .true. + mesg = trim(mesg)//" default = "//trim(time_string(default)) + endif if (mesgHasBeenDocumented(doc, varName, mesg)) return ! Avoid duplicates - call writeMessageAndDesc(doc, mesg, desc, equalsDefault, & - layoutParam=layoutParam, debuggingParam=debuggingParam) + call writeMessageAndDesc(doc, mesg, desc, equalsDefault, debuggingParam=debuggingParam) endif end subroutine doc_param_time @@ -545,6 +548,26 @@ end subroutine writeMessageAndDesc ! ---------------------------------------------------------------------- +!> This function returns a string with a time type formatted as seconds (perhaps including a +!! fractional number of seconds) and days +function time_string(time) + type(time_type), intent(in) :: time !< The time type being translated + character(len=40) :: time_string + + ! Local variables + integer :: secs, days, ticks, ticks_per_sec + + call get_time(Time, secs, days, ticks) + + time_string = trim(adjustl(int_string(days))) // ":" // trim(adjustl(int_string(secs))) + if (ticks /= 0) then + ticks_per_sec = get_ticks_per_second() + time_string = trim(time_string) // ":" // & + trim(adjustl(int_string(ticks)))//"/"//trim(adjustl(int_string(ticks_per_sec))) + endif + +end function time_string + !> This function returns a string with a real formatted like '(G)' function real_string(val) real, intent(in) :: val !< The value being written into a string @@ -675,7 +698,7 @@ function logical_string(val) end function logical_string !> This function returns a string for formatted parameter assignment -function define_string(doc,varName,valString,units) +function define_string(doc, 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 @@ -696,7 +719,7 @@ function define_string(doc,varName,valString,units) end function define_string !> This function returns a string for formatted false logicals -function undef_string(doc,varName,units) +function undef_string(doc, 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 diff --git a/src/framework/MOM_file_parser.F90 b/src/framework/MOM_file_parser.F90 index 00ed8152c9..8109890736 100644 --- a/src/framework/MOM_file_parser.F90 +++ b/src/framework/MOM_file_parser.F90 @@ -1556,8 +1556,7 @@ subroutine log_param_time(CS, modulename, varname, value, desc, units, & call doc_param(CS%doc, varname, desc, myunits, real_time) endif else - myunits='not defined'; if (present(units)) write(myunits(1:240),'(A)') trim(units) - call doc_param(CS%doc, varname, desc, myunits, value, default) + call doc_param(CS%doc, varname, desc, value, default, units=units) endif endif From e23f03c811db789b8d7346c437b25b368d9ac1e0 Mon Sep 17 00:00:00 2001 From: Andrew Shao Date: Tue, 17 Mar 2020 14:08:07 -0400 Subject: [PATCH 104/316] Fix compilation errors - Rename `h_dest` to `h_target` in routine and in signature - Remove extraneous logic --- src/framework/MOM_diag_mediator.F90 | 4 ++-- src/framework/MOM_diag_remap.F90 | 12 +++--------- 2 files changed, 5 insertions(+), 11 deletions(-) diff --git a/src/framework/MOM_diag_mediator.F90 b/src/framework/MOM_diag_mediator.F90 index f18b63f82d..45376b628f 100644 --- a/src/framework/MOM_diag_mediator.F90 +++ b/src/framework/MOM_diag_mediator.F90 @@ -1506,7 +1506,7 @@ subroutine post_data_3d(diag_field_id, field, diag_cs, is_static, mask, alt_h) allocate(remapped_field(size(field,1), size(field,2), diag%axes%nz)) call vertically_reintegrate_diag_field( & diag_cs%diag_remap_cs(diag%axes%vertical_coordinate_number), diag_cs%G, & - diag_cs%h_extensive, + diag_cs%h_begin, & diag_cs%diag_remap_cs(diag%axes%vertical_coordinate_number)%h_extensive, & staggered_in_x, staggered_in_y, diag%axes%mask3d, diag_cs%missing_value, & field, remapped_field) @@ -3258,7 +3258,7 @@ subroutine diag_update_remap_grids(diag_cs, alt_h, alt_T, alt_S, update_intensiv enddo endif if (update_extensive_local) then - CS%h_begin(:,:,:) = CS%h(:,:,:) + diag_cs%h_begin(:,:,:) = diag_cs%h(:,:,:) do i=1, diag_cs%num_diag_coords call diag_remap_update(diag_cs%diag_remap_cs(i), diag_cs%G, diag_cs%GV, diag_cs%US, h_diag, T_diag, S_diag, & diag_cs%eqn_of_state, diag_cs%diag_remap_cs(i)%h_extensive) diff --git a/src/framework/MOM_diag_remap.F90 b/src/framework/MOM_diag_remap.F90 index bb72ad1af0..77aa9efb91 100644 --- a/src/framework/MOM_diag_remap.F90 +++ b/src/framework/MOM_diag_remap.F90 @@ -312,12 +312,6 @@ subroutine diag_remap_update(remap_cs, G, GV, US, h, T, S, eqn_of_state, h_targe remap_cs%initialized = .true. endif - if (intensive) then - h_target => remap_cs%h - else - h_target => remap_cs%h_extensive - endif - ! Calculate remapping thicknesses for different target grids based on ! nominal/target interface locations. This happens for every call on the ! assumption that h, T, S has changed. @@ -493,11 +487,11 @@ subroutine diag_remap_calc_hmask(remap_cs, G, mask) end subroutine diag_remap_calc_hmask !> Vertically re-grid an already vertically-integrated diagnostic field to alternative vertical grid. -subroutine vertically_reintegrate_diag_field(remap_cs, G, h, h_dest, staggered_in_x, staggered_in_y, & +subroutine vertically_reintegrate_diag_field(remap_cs, G, h, h_target, staggered_in_x, staggered_in_y, & mask, missing_value, field, reintegrated_field) type(diag_remap_ctrl), intent(in) :: remap_cs !< Diagnostic coodinate control structure - type(ocean_grid_type), intent(in) :: G !< Ocean grid structure - real, dimension(:,:,:), intent(in) :: h !< The thicknesses of the source grid + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + real, dimension(:,:,:), intent(in) :: h !< The thicknesses of the source grid real, dimension(:,:,:), intent(in) :: h_target !< The thicknesses of the target grid logical, intent(in) :: staggered_in_x !< True is the x-axis location is at u or q points logical, intent(in) :: staggered_in_y !< True is the y-axis location is at v or q points From 9a330fab88ac5fccb4ac6513c5713ce0ee821ba0 Mon Sep 17 00:00:00 2001 From: Andrew Shao Date: Tue, 17 Mar 2020 14:56:38 -0400 Subject: [PATCH 105/316] Loop over recreation of diagnostic grid explicitly --- src/framework/MOM_diag_remap.F90 | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/src/framework/MOM_diag_remap.F90 b/src/framework/MOM_diag_remap.F90 index 77aa9efb91..000a3ce518 100644 --- a/src/framework/MOM_diag_remap.F90 +++ b/src/framework/MOM_diag_remap.F90 @@ -341,7 +341,9 @@ subroutine diag_remap_update(remap_cs, G, GV, US, h, T, S, eqn_of_state, h_targe ! US%Z_to_m*G%bathyT(i,j), sum(h(i,j,:)), zInterfaces) call MOM_error(FATAL,"diag_remap_update: HYCOM1 coordinate not coded for diagnostics yet!") endif - h_target(i,j,:) = zInterfaces(1:nz) - zInterfaces(2:nz+1) + do k = 1,nz + h_target(i,j,k) = zInterfaces(k) - zInterfaces(k+1) + enddo enddo ; enddo end subroutine diag_remap_update From 22ddb98dad136a040d21d878330bd112ff288827 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Tue, 17 Mar 2020 19:14:50 -0400 Subject: [PATCH 106/316] Corrected the units in ALE variable documentation Added or corrected comments describing the units of many of the variables in the ALE code. All solutions are bitwise identical, although there are some unit changes in arguments to unused subroutines. --- src/ALE/MOM_regridding.F90 | 66 ++++++++-------- src/ALE/coord_hycom.F90 | 46 ++++++----- src/ALE/coord_rho.F90 | 98 ++++++++++++----------- src/ALE/coord_slight.F90 | 56 ++++++------- src/ALE/coord_zlike.F90 | 18 +++-- src/ALE/regrid_interp.F90 | 118 +++++++++++++--------------- src/framework/MOM_diag_mediator.F90 | 23 +++--- src/framework/MOM_diag_remap.F90 | 15 ++-- 8 files changed, 220 insertions(+), 220 deletions(-) diff --git a/src/ALE/MOM_regridding.F90 b/src/ALE/MOM_regridding.F90 index e23e740c9c..b1897aeb2e 100644 --- a/src/ALE/MOM_regridding.F90 +++ b/src/ALE/MOM_regridding.F90 @@ -84,7 +84,7 @@ module MOM_regridding !> Minimum thickness allowed when building the new grid through regridding [H ~> m or kg m-2]. real :: min_thickness - !> Reference pressure for potential density calculations (Pa) + !> Reference pressure for potential density calculations [Pa] real :: ref_pressure = 2.e7 !> Weight given to old coordinate when blending between new and old grids [nondim] @@ -203,6 +203,7 @@ subroutine initialize_regridding(CS, GV, US, max_depth, param_file, mdl, coord_m real :: maximum_depth ! The maximum depth of the ocean [m] (not in Z). real :: dz_fixed_sfc, Rho_avg_depth, nlay_sfc_int real :: adaptTimeRatio, adaptZoom, adaptZoomCoeff, adaptBuoyCoeff, adaptAlpha + real :: adaptDrho0 ! Reference density difference for stratification-dependent diffusion. [R ~> kg m-3] integer :: nz_fixed_sfc, k, nzf(4) real, dimension(:), allocatable :: dz ! Resolution (thickness) in units of coordinate, which may be [m] ! or [Z ~> m] or [H ~> m or kg m-2] or [R ~> kg m-3] or other units. @@ -574,26 +575,26 @@ subroutine initialize_regridding(CS, GV, US, max_depth, param_file, mdl, coord_m if (coordinateMode(coord_mode) == REGRIDDING_ADAPTIVE) then call get_param(param_file, mdl, "ADAPT_TIME_RATIO", adaptTimeRatio, & - "Ratio of ALE timestep to grid timescale.", units="nondim", default=1e-1) + "Ratio of ALE timestep to grid timescale.", units="nondim", default=1.0e-1) call get_param(param_file, mdl, "ADAPT_ZOOM_DEPTH", adaptZoom, & - "Depth of near-surface zooming region.", units="m", default=200.0, scale=GV%m_to_H) + "Depth of near-surface zooming region.", units="m", default=200.0, scale=GV%m_to_H) call get_param(param_file, mdl, "ADAPT_ZOOM_COEFF", adaptZoomCoeff, & - "Coefficient of near-surface zooming diffusivity.", & - units="nondim", default=0.2) + "Coefficient of near-surface zooming diffusivity.", units="nondim", default=0.2) call get_param(param_file, mdl, "ADAPT_BUOY_COEFF", adaptBuoyCoeff, & - "Coefficient of buoyancy diffusivity.", & - units="nondim", default=0.8) + "Coefficient of buoyancy diffusivity.", units="nondim", default=0.8) call get_param(param_file, mdl, "ADAPT_ALPHA", adaptAlpha, & - "Scaling on optimization tendency.", & - units="nondim", default=1.0) + "Scaling on optimization tendency.", units="nondim", default=1.0) call get_param(param_file, mdl, "ADAPT_DO_MIN_DEPTH", tmpLogical, & - "If true, make a HyCOM-like mixed layer by preventing interfaces "//& - "from being shallower than the depths specified by the regridding coordinate.", & - default=.false.) + "If true, make a HyCOM-like mixed layer by preventing interfaces "//& + "from being shallower than the depths specified by the regridding coordinate.", & + default=.false.) + call get_param(param_file, mdl, "ADAPT_DRHO0", adaptDrho0, & + "Reference density difference for stratification-dependent diffusion.", & + units="kg m-3", default=0.5, scale=US%kg_m3_to_R) call set_regrid_params(CS, adaptTimeRatio=adaptTimeRatio, adaptZoom=adaptZoom, & adaptZoomCoeff=adaptZoomCoeff, adaptBuoyCoeff=adaptBuoyCoeff, adaptAlpha=adaptAlpha, & - adaptDoMin=tmpLogical) + adaptDoMin=tmpLogical, adaptDrho0=US%R_to_kg_m3*adaptDrho0) endif if (main_parameters .and. coord_is_state_dependent) then @@ -1012,9 +1013,9 @@ end subroutine check_grid_column 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 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] + real, dimension(nk+1), intent(in) :: z_old !< Old grid position [H ~> m or kg m-2] + real, dimension(CS%nk+1), intent(in) :: z_new !< New grid position [H ~> m or kg m-2] + real, dimension(CS%nk+1), intent(inout) :: dz_g !< Change in interface positions [H ~> m or kg m-2] ! Local variables real :: sgn ! The sign convention for downward. real :: dz_tgt, zr1, z_old_k @@ -1156,26 +1157,21 @@ subroutine build_zstar_grid( CS, G, GV, h, dzInterface, frac_shelf_h) real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] real, dimension(SZI_(G),SZJ_(G), CS%nk+1), intent(inout) :: dzInterface !< The change in interface depth !! [H ~> m or kg m-2]. - real, dimension(:,:), optional, pointer :: frac_shelf_h !< Fractional ice shelf coverage. + real, dimension(:,:), optional, pointer :: frac_shelf_h !< Fractional ice shelf coverage [nondim]. ! Local variables - integer :: i, j, k - integer :: nz - real :: nominalDepth, totalThickness, dh - real, dimension(SZK_(GV)+1) :: zOld, zNew - real :: minThickness + real :: nominalDepth, totalThickness, dh ! Depths and thicknesses [H ~> m or kg m-2] + real, dimension(SZK_(GV)+1) :: zOld, zNew ! Coordinate interface heights [H ~> m or kg m-2] + integer :: i, j, k, nz logical :: ice_shelf nz = GV%ke - minThickness = CS%min_thickness ice_shelf = .false. if (present(frac_shelf_h)) then if (associated(frac_shelf_h)) ice_shelf = .true. endif -!$OMP parallel do default(none) shared(G,GV,dzInterface,CS,nz,h,frac_shelf_h, & -!$OMP ice_shelf,minThickness) & -!$OMP private(nominalDepth,totalThickness, & -!$OMP zNew,dh,zOld) +!$OMP parallel do default(none) shared(G,GV,dzInterface,CS,nz,h,frac_shelf_h,ice_shelf) & +!$OMP private(nominalDepth,totalThickness,zNew,dh,zOld) do j = G%jsc-1,G%jec+1 do i = G%isc-1,G%iec+1 @@ -1218,7 +1214,7 @@ subroutine build_zstar_grid( CS, G, GV, h, dzInterface, frac_shelf_h) #ifdef __DO_SAFETY_CHECKS__ dh=max(nominalDepth,totalThickness) if (abs(zNew(1)-zOld(1))>(nz-1)*0.5*epsilon(dh)*dh) then - write(0,*) 'min_thickness=',minThickness + write(0,*) 'min_thickness=',CS%min_thickness write(0,*) 'nominalDepth=',nominalDepth,'totalThickness=',totalThickness write(0,*) 'dzInterface(1) = ',dzInterface(i,j,1),epsilon(dh),nz do k=1,nz+1 @@ -1350,10 +1346,11 @@ subroutine build_rho_grid( G, GV, h, tv, dzInterface, remapCS, CS ) ! Local variables integer :: nz integer :: i, j, k - real :: nominalDepth, totalThickness + real :: nominalDepth ! Depth of the bottom of the ocean, positive downward [H ~> m or kg m-2] real, dimension(SZK_(GV)+1) :: zOld, zNew - real :: h_neglect, h_neglect_edge + real :: h_neglect, h_neglect_edge ! Negligible thicknesses [H ~> m or kg m-2] #ifdef __DO_SAFETY_CHECKS__ + real :: totalThickness real :: dh #endif @@ -1539,8 +1536,8 @@ subroutine build_grid_adaptive(G, GV, h, tv, dzInterface, remapCS, CS) real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1) :: tInt, sInt ! current interface positions and after tendency term is applied ! positive downward - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1) :: zInt - real, dimension(SZK_(GV)+1) :: zNext + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1) :: zInt ! Interface depths [H ~> m or kg m-2] + real, dimension(SZK_(GV)+1) :: zNext ! New interface depths [H ~> m or kg m-2] nz = GV%ke @@ -2231,7 +2228,7 @@ subroutine set_regrid_params( CS, boundary_extrapolation, min_thickness, old_gri compress_fraction, dz_min_surface, nz_fixed_surface, Rho_ML_avg_depth, & nlay_ML_to_interior, fix_haloclines, halocline_filt_len, & halocline_strat_tol, integrate_downward_for_e, remap_answers_2018, & - adaptTimeRatio, adaptZoom, adaptZoomCoeff, adaptBuoyCoeff, adaptAlpha, adaptDoMin) + adaptTimeRatio, adaptZoom, adaptZoomCoeff, adaptBuoyCoeff, adaptAlpha, adaptDoMin, adaptDrho0) 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 @@ -2266,6 +2263,8 @@ subroutine set_regrid_params( CS, boundary_extrapolation, min_thickness, old_gri 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. + real, optional, intent(in) :: adaptDrho0 !< Reference density difference for stratification-dependent + !! diffusion. [kg m-3] 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) @@ -2322,6 +2321,7 @@ subroutine set_regrid_params( CS, boundary_extrapolation, min_thickness, old_gri if (present(adaptBuoyCoeff)) call set_adapt_params(CS%adapt_CS, adaptBuoyCoeff=adaptBuoyCoeff) if (present(adaptAlpha)) call set_adapt_params(CS%adapt_CS, adaptAlpha=adaptAlpha) if (present(adaptDoMin)) call set_adapt_params(CS%adapt_CS, adaptDoMin=adaptDoMin) + if (present(adaptDrho0)) call set_adapt_params(CS%adapt_CS, adaptDrho0=adaptDrho0) end select end subroutine set_regrid_params diff --git a/src/ALE/coord_hycom.F90 b/src/ALE/coord_hycom.F90 index 76c346c82e..1686ac51c9 100644 --- a/src/ALE/coord_hycom.F90 +++ b/src/ALE/coord_hycom.F90 @@ -15,7 +15,7 @@ module coord_hycom !> Number of layers/levels in generated grid integer :: nk - !> Nominal near-surface resolution + !> Nominal near-surface resolution [Z ~> m] real, allocatable, dimension(:) :: coordinateResolution !> Nominal density of interfaces [R ~> kg m-3] @@ -24,10 +24,10 @@ module coord_hycom !> Density scaling factor [R m3 kg-1 ~> 1] real :: kg_m3_to_R - !> Maximum depths of interfaces + !> Maximum depths of interfaces [H ~> m or kg m-2] real, allocatable, dimension(:) :: max_interface_depths - !> Maximum thicknesses of layers + !> Maximum thicknesses of layers [H ~> m or kg m-2] real, allocatable, dimension(:) :: max_layer_thickness !> Interpolation control structure @@ -42,7 +42,7 @@ module coord_hycom subroutine init_coord_hycom(CS, nk, coordinateResolution, target_density, interp_CS, rho_scale) type(hycom_CS), pointer :: CS !< Unassociated pointer to hold the control structure integer, intent(in) :: nk !< Number of layers in generated grid - real, dimension(nk), intent(in) :: coordinateResolution !< Nominal near-surface resolution [m] + real, dimension(nk), intent(in) :: coordinateResolution !< Nominal near-surface resolution [Z ~> m] real, dimension(nk+1),intent(in) :: target_density !< Interface target densities [R ~> kg m-3] type(interp_CS_type), intent(in) :: interp_CS !< Controls for interpolation real, optional, intent(in) :: rho_scale !< A dimensional scaling factor for target_density @@ -76,8 +76,8 @@ 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 !< 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, dimension(:), optional, intent(in) :: max_interface_depths !< Maximum depths of interfaces [H ~> m or kg m-2] + real, dimension(:), optional, intent(in) :: max_layer_thickness !< Maximum thicknesses of layers [H ~> m or kg m-2] 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") @@ -102,33 +102,31 @@ end subroutine set_hycom_params !> Build a HyCOM coordinate column subroutine build_hycom1_column(CS, eqn_of_state, nz, depth, h, T, S, p_col, & z_col, z_col_new, zScale, h_neglect, h_neglect_edge) - type(hycom_CS), intent(in) :: CS !< Coordinate control structure + type(hycom_CS), intent(in) :: CS !< Coordinate control structure type(EOS_type), pointer :: eqn_of_state !< Equation of state structure - integer, intent(in) :: nz !< Number of levels + integer, intent(in) :: nz !< Number of levels real, intent(in) :: depth !< Depth of ocean bottom (positive [H ~> m or kg m-2]) - real, dimension(nz), intent(in) :: T !< Temperature of column [degC] - real, dimension(nz), intent(in) :: S !< Salinity of column [ppt] - real, dimension(nz), intent(in) :: h !< Layer thicknesses, in [m] or [H ~> m or kg m-2] + real, dimension(nz), intent(in) :: T !< Temperature of column [degC] + real, dimension(nz), intent(in) :: S !< Salinity of column [ppt] + real, dimension(nz), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] real, dimension(nz), intent(in) :: p_col !< Layer pressure [Pa] real, dimension(nz+1), intent(in) :: z_col !< Interface positions relative to the surface [H ~> 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 - !! purpose of cell reconstructions - !! in the same units as h. - real, optional, intent(in) :: h_neglect_edge !< A negligibly small width - !! for the purpose of edge value calculations - !! in the same units as h0. + real, dimension(CS%nk+1), intent(inout) :: z_col_new !< Absolute positions of interfaces [H ~> m or kg m-2] + real, optional, intent(in) :: zScale !< Scaling factor from the input coordinate thicknesses in [Z ~> m] + !! to desired units for zInterface, perhaps GV%Z_to_H. + real, optional, intent(in) :: h_neglect !< A negligibly small width for the purpose of + !! cell reconstruction [H ~> m or kg m-2] + real, optional, intent(in) :: h_neglect_edge !< A negligibly small width for the purpose of + !! edge value calculation [H ~> m or kg m-2] ! Local variables integer :: k real, dimension(nz) :: rho_col ! Layer densities in a column [R ~> kg m-3] 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 when using z* [Z ~> m] - real :: hNew + real :: z_scale ! A scaling factor from the input thicknesses to the target thicknesses, + ! perhaps 1 or a factor in [H Z-1 ~> 1 or kg m-3] + real :: stretching ! z* stretching, converts z* to z [nondim]. + real :: nominal_z ! Nominal depth of interface when using z* [H ~> m or kg m-2] logical :: maximum_depths_set ! If true, the maximum depths of interface have been set. logical :: maximum_h_set ! If true, the maximum layer thicknesses have been set. diff --git a/src/ALE/coord_rho.F90 b/src/ALE/coord_rho.F90 index 53b83644af..a78b1dd749 100644 --- a/src/ALE/coord_rho.F90 +++ b/src/ALE/coord_rho.F90 @@ -36,11 +36,6 @@ module coord_rho type(interp_CS_type) :: interp_CS end type rho_CS -!> Maximum number of regridding iterations -integer, parameter :: NB_REGRIDDING_ITERATIONS = 1 -!> Deviation tolerance between succesive grids in regridding iterations -real, parameter :: DEVIATION_TOLERANCE = 1e-10 - public init_coord_rho, set_rho_params, build_rho_column, old_inflate_layers_1d, end_coord_rho contains @@ -50,7 +45,7 @@ subroutine init_coord_rho(CS, nk, ref_pressure, target_density, interp_CS, rho_s type(rho_CS), pointer :: CS !< Unassociated pointer to hold the control structure integer, intent(in) :: nk !< Number of layers in the grid real, intent(in) :: ref_pressure !< Coordinate reference pressure [Pa] - real, dimension(:), intent(in) :: target_density !< Nominal density of interfaces [kg m-3 or R ~> kg m-3] + real, dimension(:), intent(in) :: target_density !< Nominal density of interfaces [R ~> kg m-3] type(interp_CS_type), intent(in) :: interp_CS !< Controls for interpolation real, optional, intent(in) :: rho_scale !< A dimensional scaling factor for target_density @@ -103,24 +98,24 @@ subroutine build_rho_column(CS, nz, depth, h, T, S, eqn_of_state, z_interface, & integer, intent(in) :: nz !< Number of levels on source grid (i.e. length of h, T, S) real, intent(in) :: depth !< Depth of ocean bottom (positive in m) real, dimension(nz), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] - real, dimension(nz), intent(in) :: T !< T for source column - real, dimension(nz), intent(in) :: S !< S for source column + real, dimension(nz), intent(in) :: T !< Temperature for source column [degC] + real, dimension(nz), intent(in) :: S !< Salinity for source column [ppt] type(EOS_type), pointer :: eqn_of_state !< Equation of state structure real, dimension(CS%nk+1), & intent(inout) :: z_interface !< Absolute positions of interfaces - real, optional, intent(in) :: h_neglect !< A negligibly small width for the - !! purpose of cell reconstructions - !! in the same units as h0. - real, optional, intent(in) :: h_neglect_edge !< A negligibly small width - !! for the purpose of edge value calculations - !! in the same units as h0. + real, optional, intent(in) :: h_neglect !< A negligibly small width for the purpose + !! of cell reconstructions [H ~> m or kg m-2] + real, optional, intent(in) :: h_neglect_edge !< A negligibly small width for the purpose + !! of edge value calculations [H ~> m or kg m-2] + ! Local variables integer :: k, count_nonzero_layers integer, dimension(nz) :: mapping - real, dimension(nz) :: p, h_nv + real, dimension(nz) :: pres ! Pressures used to calculate density [Pa] + real, dimension(nz) :: h_nv ! Thicknesses of non-vanishing layers [H ~> m or kg m-2] real, dimension(nz) :: densities ! Layer density [R ~> kg m-3] - real, dimension(nz+1) :: xTmp - real, dimension(CS%nk) :: h_new ! New thicknesses + real, dimension(nz+1) :: xTmp ! Temporary positions [H ~> m or kg m-2] + real, dimension(CS%nk) :: h_new ! New thicknesses [H ~> m or kg m-2] real, dimension(CS%nk+1) :: x1 ! Construct source column with vanished layers removed (stored in h_nv) @@ -133,8 +128,8 @@ subroutine build_rho_column(CS, nz, depth, h, T, S, eqn_of_state, z_interface, & enddo ! Compute densities on source column - p(:) = CS%ref_pressure - call calculate_density(T, S, p, densities, 1, nz, eqn_of_state, scale=CS%kg_m3_to_R) + pres(:) = CS%ref_pressure + call calculate_density(T, S, pres, densities, 1, nz, eqn_of_state, scale=CS%kg_m3_to_R) do k = 1,count_nonzero_layers densities(k) = densities(mapping(k)) enddo @@ -179,6 +174,8 @@ subroutine build_rho_column(CS, nz, depth, h, T, S, eqn_of_state, z_interface, & end subroutine build_rho_column +!### build_rho_column_iteratively is never used or called. + !> Iteratively build a rho coordinate column !! !! The algorithm operates as follows within each column: @@ -192,7 +189,7 @@ end subroutine build_rho_column !! 5. Return to step 1 until convergence or until the maximum number of !! iterations is reached, whichever comes first. subroutine build_rho_column_iteratively(CS, remapCS, nz, depth, h, T, S, eqn_of_state, & - zInterface, h_neglect, h_neglect_edge) + zInterface, h_neglect, h_neglect_edge, dev_tol) type(rho_CS), intent(in) :: CS !< Regridding control structure type(remapping_CS), intent(in) :: remapCS !< Remapping parameters and options integer, intent(in) :: nz !< Number of levels @@ -208,29 +205,39 @@ subroutine build_rho_column_iteratively(CS, remapCS, nz, depth, h, T, S, eqn_of_ real, optional, intent(in) :: h_neglect_edge !< A negligibly small width !! for the purpose of edge value calculations !! in the same units as h [Z ~> m] + real, optional, intent(in) :: dev_tol !< The tolerance for the deviation between + !! successive grids for determining when the + !! iterative solver has converged [Z ~> m] + ! Local variables - integer :: k, m - integer :: count_nonzero_layers - real :: deviation ! When iterating to determine the final - ! grid, this is the deviation between two - ! successive grids. - real :: threshold - real, dimension(nz) :: p, densities, T_tmp, S_tmp, Tmp - integer, dimension(nz) :: mapping - real, dimension(nz) :: h0, h1, hTmp - real, dimension(nz+1) :: x0, x1, xTmp + real, dimension(nz+1) :: x0, x1, xTmp ! Temporary interface heights [Z ~> m] + real, dimension(nz) :: pres ! The pressure used in the equation of state [Pa]. + real, dimension(nz) :: densities ! Layer densities [R ~> kg m-3] + real, dimension(nz) :: T_tmp, S_tmp ! A temporary profile of temperature [degC] and salinity [ppt]. + real, dimension(nz) :: Tmp ! A temporary variable holding a remapped variable. + real, dimension(nz) :: h0, h1, hTmp ! Temporary thicknesses [Z ~> m] + real :: deviation ! When iterating to determine the final grid, this is the + ! deviation between two successive grids [Z ~> m]. + real :: deviation_tol ! Deviation tolerance between succesive grids in + ! regridding iterations [Z ~> m] + real :: threshold ! The minimum thickness for a layer to be considered to exist [Z ~> m] + integer, dimension(nz) :: mapping ! The indices of the massive layers in the initial column. + integer :: k, m, count_nonzero_layers + + ! Maximum number of regridding iterations + integer, parameter :: NB_REGRIDDING_ITERATIONS = 1 threshold = CS%min_thickness - p(:) = CS%ref_pressure + pres(:) = CS%ref_pressure T_tmp(:) = T(:) S_tmp(:) = S(:) h0(:) = h(:) ! Start iterations to build grid m = 1 - deviation = 1e10 - do while ( ( m <= NB_REGRIDDING_ITERATIONS ) .and. & - ( deviation > DEVIATION_TOLERANCE ) ) + deviation_tol = 1.0e-15*depth ; if (present(dev_tol)) deviation_tol = dev_tol + + do m=1,NB_REGRIDDING_ITERATIONS ! Construct column with vanished layers removed call copy_finite_thicknesses(nz, h0, threshold, count_nonzero_layers, hTmp, mapping) @@ -245,7 +252,7 @@ subroutine build_rho_column_iteratively(CS, remapCS, nz, depth, h, T, S, eqn_of_ enddo ! Compute densities within current water column - call calculate_density( T_tmp, S_tmp, p, densities, & + call calculate_density( T_tmp, S_tmp, pres, densities, & 1, nz, eqn_of_state, scale=CS%kg_m3_to_R) do k = 1,count_nonzero_layers @@ -282,11 +289,10 @@ subroutine build_rho_column_iteratively(CS, remapCS, nz, depth, h, T, S, eqn_of_ enddo deviation = sqrt( deviation / (nz-1) ) - m = m + 1 + if ( deviation <= deviation_tol ) exit ! Copy final grid onto start grid for next iteration h0(:) = h1(:) - enddo ! end regridding iterations if (CS%integrate_downward_for_e) then @@ -309,16 +315,18 @@ subroutine build_rho_column_iteratively(CS, remapCS, nz, depth, h, T, S, eqn_of_ end subroutine build_rho_column_iteratively !> Copy column thicknesses with vanished layers removed -subroutine copy_finite_thicknesses(nk, h_in, threshold, nout, h_out, mapping) - integer, intent(in) :: nk !< Number of layer for h_in, T_in, S_in - real, dimension(nk), intent(in) :: h_in !< Thickness of input column - real, intent(in) :: threshold !< Thickness threshold defining vanished layers - integer, intent(out) :: nout !< Number of non-vanished layers - real, dimension(nk), intent(out) :: h_out !< Thickness of output column +subroutine copy_finite_thicknesses(nk, h_in, thresh, nout, h_out, mapping) + integer, intent(in) :: nk !< Number of layer for h_in, T_in, S_in + real, dimension(nk), intent(in) :: h_in !< Thickness of input column [H ~> m or kg m-2] or [Z ~> m] + real, intent(in) :: thresh !< Thickness threshold defining vanished + !! layers [H ~> m or kg m-2] or [Z ~> m] + integer, intent(out) :: nout !< Number of non-vanished layers + real, dimension(nk), intent(out) :: h_out !< Thickness of output column [H ~> m or kg m-2] or [Z ~> m] integer, dimension(nk), intent(out) :: mapping !< Index of k-out corresponding to k-in ! Local variables integer :: k, k_thickest - real :: thickness_in_vanished, thickest_h_out + real :: thickness_in_vanished ! Summed thicknesses in discarded layers [H ~> m or kg m-2] or [Z ~> m] + real :: thickest_h_out ! Thickness of the thickest layer [H ~> m or kg m-2] or [Z ~> m] ! Build up new grid nout = 0 @@ -328,7 +336,7 @@ subroutine copy_finite_thicknesses(nk, h_in, threshold, nout, h_out, mapping) do k = 1, nk mapping(k) = nout ! Note k>=nout always h_out(k) = 0. ! Make sure h_out is set everywhere - if (h_in(k) > threshold) then + if (h_in(k) > thresh) then ! For non-vanished layers nout = nout + 1 mapping(nout) = k diff --git a/src/ALE/coord_slight.F90 b/src/ALE/coord_slight.F90 index 92de6e1ec3..30f2597090 100644 --- a/src/ALE/coord_slight.F90 +++ b/src/ALE/coord_slight.F90 @@ -76,7 +76,7 @@ subroutine init_coord_slight(CS, nk, ref_pressure, target_density, interp_CS, m_ type(slight_CS), pointer :: CS !< Unassociated pointer to hold the control structure integer, intent(in) :: nk !< Number of layers in the grid real, intent(in) :: ref_pressure !< Coordinate reference pressure [Pa] - real, dimension(:), intent(in) :: target_density !< Nominal density of interfaces [kg m-3] + real, dimension(:), intent(in) :: target_density !< Nominal density of interfaces [R ~> kg m-3] type(interp_CS_type), intent(in) :: interp_CS !< Controls for interpolation real, optional, intent(in) :: m_to_H !< A conversion factor from m to the units of thicknesses real, optional, intent(in) :: rho_scale !< A dimensional scaling factor for target_density @@ -202,10 +202,10 @@ subroutine build_slight_column(CS, eqn_of_state, H_to_Pa, H_subroundoff, & real, optional, intent(in) :: h_neglect_edge !< A negligibly small width for the purpose !! of edge value calculations [H ~> m or kg m-2]. ! Local variables - real, dimension(nz) :: rho_col ! Layer densities [R ~> kg m-3] - real, dimension(nz) :: T_f, S_f ! Filtered ayer quantities + real, dimension(nz) :: rho_col ! Layer densities [R ~> kg m-3] + real, dimension(nz) :: T_f, S_f ! Filtered layer temperature [degC] and salinity [ppt] logical, dimension(nz+1) :: reliable ! If true, this interface is in a reliable position. - real, dimension(nz+1) :: T_int, S_int ! Temperature and salinity interpolated to interfaces. + real, dimension(nz+1) :: T_int, S_int ! Temperature [degC] and salinity [ppt] interpolated to interfaces. real, dimension(nz+1) :: rho_tmp ! A temporary density [R ~> kg m-3] real, dimension(nz+1) :: drho_dp ! The partial derivative of density with pressure [kg m-3 Pa-1] real, dimension(nz+1) :: p_IS, p_R @@ -224,7 +224,7 @@ subroutine build_slight_column(CS, eqn_of_state, H_to_Pa, H_subroundoff, & real :: z_int_unst real :: dz ! A uniform layer thickness in very shallow water [H ~> m or kg m-2]. real :: dz_ur ! The total thickness of an unstable region [H ~> m or kg m-2]. - real :: wgt, cowgt ! A weight and its complement, nondim. + real :: wgt, cowgt ! A weight and its complement [nondim]. real :: rho_ml_av ! The average potential density in a near-surface region [R ~> kg m-3]. real :: H_ml_av ! A thickness to try to use in taking the near-surface average [H ~> m or kg m-2]. real :: rho_x_z ! A cumulative integral of a density [R H ~> kg m-2 or kg2 m-5]. @@ -492,38 +492,38 @@ end subroutine build_slight_column subroutine rho_interfaces_col(rho_col, h_col, z_col, rho_tgt, nz, z_col_new, & CS, reliable, debug, h_neglect, h_neglect_edge) integer, intent(in) :: nz !< Number of layers - real, dimension(nz), intent(in) :: rho_col !< Initial layer reference densities. - real, dimension(nz), intent(in) :: h_col !< Initial layer thicknesses. - real, dimension(nz+1), intent(in) :: z_col !< Initial interface heights. + real, dimension(nz), intent(in) :: rho_col !< Initial layer reference densities [R ~> kg m-3]. + real, dimension(nz), intent(in) :: h_col !< Initial layer thicknesses [H ~> m or kg m-2]. + real, dimension(nz+1), intent(in) :: z_col !< Initial interface heights [H ~> m or kg m-2]. real, dimension(nz+1), intent(in) :: rho_tgt !< Interface target densities. - real, dimension(nz+1), intent(inout) :: z_col_new !< New interface heights. + real, dimension(nz+1), intent(inout) :: z_col_new !< New interface heights [H ~> m or kg m-2]. type(slight_CS), intent(in) :: CS !< Coordinate control structure logical, dimension(nz+1), intent(inout) :: reliable !< If true, the interface positions !! are well defined from a stable region. - logical, optional, intent(in) :: debug !< If present and true, do debugging checks. - real, optional, intent(in) :: h_neglect !< A negligibly small width for the - !! purpose of cell reconstructions - !! in the same units as h_col. - real, optional, intent(in) :: h_neglect_edge !< A negligibly small width - !! for the purpose of edge value calculations - !! in the same units as h_col. + logical, optional, intent(in) :: debug !< If present and true, do debugging checks. + real, optional, intent(in) :: h_neglect !< A negligibly small width for the purpose of + !! cell reconstructions [H ~> m or kg m-2] + real, optional, intent(in) :: h_neglect_edge !< A negligibly small width for the purpose + !! of edge value calculations [H ~> m or kg m-2] real, dimension(nz+1) :: ru_max_int ! The maximum and minimum densities in - real, dimension(nz+1) :: ru_min_int ! an unstable region around an interface. + real, dimension(nz+1) :: ru_min_int ! an unstable region around an interface [R ~> kg m-3]. real, dimension(nz) :: ru_max_lay ! The maximum and minimum densities in - real, dimension(nz) :: ru_min_lay ! an unstable region containing a layer. - real, dimension(nz,2) :: ppoly_i_E ! Edge value of polynomial - real, dimension(nz,2) :: ppoly_i_S ! Edge slope of polynomial - real, dimension(nz,DEGREE_MAX+1) :: ppoly_i_coefficients ! Coefficients of polynomial + real, dimension(nz) :: ru_min_lay ! an unstable region containing a layer [R ~> kg m-3]. + real, dimension(nz,2) :: ppoly_i_E ! Edge value of polynomial [R ~> kg m-3] + real, dimension(nz,2) :: ppoly_i_S ! Edge slope of polynomial [R H-1 ~> kg m-4 or m-1] + real, dimension(nz,DEGREE_MAX+1) :: ppoly_i_coefficients ! Coefficients of polynomial [R ~> kg m-3] logical, dimension(nz) :: unstable_lay ! If true, this layer is in an unstable region. logical, dimension(nz+1) :: unstable_int ! If true, this interface is in an unstable region. - real :: rt ! The current target density [kg m-3]. - real :: zf ! The fractional z-position within a layer of the target density. - real :: rfn - real :: a(5) ! Coefficients of a local polynomial minus the target density. - real :: zf1, zf2, rfn1, rfn2 - real :: drfn_dzf, sgn, delta_zf, zf_prev - real :: tol + real :: rt ! The current target density [R ~> kg m-3]. + real :: zf ! The fractional z-position within a layer of the target density [nondim]. + real :: rfn ! The target density relative to the interpolated density [R ~> kg m-3] + real :: a(5) ! Coefficients of a local polynomial minus the target density [R ~> kg m-3]. + real :: zf1, zf2 ! Two previous estimates of zf [nondim] + real :: rfn1, rfn2 ! Values of rfn at zf1 and zf2 [R ~> kg m-3] + real :: drfn_dzf ! The partial derivative of rfn with zf [R ~> kg m-3] + real :: sgn, delta_zf, zf_prev ! [nondim] + real :: tol ! The tolerance for convergence of zf [nondim] logical :: k_found ! If true, the position has been found. integer :: k_layer ! The index of the stable layer containing an interface. integer :: ppoly_degree diff --git a/src/ALE/coord_zlike.F90 b/src/ALE/coord_zlike.F90 index 1f4949431d..f2ed7f0035 100644 --- a/src/ALE/coord_zlike.F90 +++ b/src/ALE/coord_zlike.F90 @@ -63,17 +63,21 @@ end subroutine set_zlike_params subroutine build_zstar_column(CS, depth, total_thickness, zInterface, & z_rigid_top, eta_orig, zScale) type(zlike_CS), intent(in) :: CS !< Coordinate control structure - real, intent(in) :: depth !< Depth of ocean bottom (positive in the output units) - real, intent(in) :: total_thickness !< Column thickness (positive in the same units as depth) + real, intent(in) :: depth !< Depth of ocean bottom (positive downward in the + !! output units), units may be [Z ~> m] or [H ~> m or kg m-2] + real, intent(in) :: total_thickness !< Column thickness (positive definite in the same + !! units as depth) [Z ~> m] or [H ~> m or kg m-2] 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) :: z_rigid_top !< The height of a rigid top (positive upward in the same + !! units as depth) [Z ~> m] or [H ~> m or kg m-2] + real, optional, intent(in) :: eta_orig !< The actual original height of the top in the same + !! units as depth) [Z ~> m] or [H ~> m or kg m-2] real, optional, intent(in) :: zScale !< Scaling factor from the target coordinate resolution !! in Z to desired units for zInterface, perhaps Z_to_H ! Local variables - real :: eta, stretching, dh, min_thickness, z0_top, z_star, z_scale + real :: eta ! Free surface height [Z ~> m] or [H ~> m or kg m-2] + real :: stretching ! A stretching factor for the coordinate [nondim] + real :: dh, min_thickness, z0_top, z_star, z_scale ! Thicknesses or heights [Z ~> m] or [H ~> m or kg m-2] integer :: k logical :: new_zstar_def diff --git a/src/ALE/regrid_interp.F90 b/src/ALE/regrid_interp.F90 index 19082292be..5a1d151487 100644 --- a/src/ALE/regrid_interp.F90 +++ b/src/ALE/regrid_interp.F90 @@ -58,13 +58,13 @@ module regrid_interp !> When the N-R algorithm produces an estimate that lies outside [0,1], the !! estimate is set to be equal to the boundary location, 0 or 1, plus or minus -!! an offset, respectively, when the derivative is zero at the boundary. +!! an offset, respectively, when the derivative is zero at the boundary [nondim]. real, public, parameter :: NR_OFFSET = 1e-6 !> Maximum number of Newton-Raphson iterations. Newton-Raphson iterations are !! used to build the new grid by finding the coordinates associated with !! target densities and interpolations of degree larger than 1. integer, public, parameter :: NR_ITERATIONS = 8 -!> Tolerance for Newton-Raphson iterations (stop when increment falls below this) +!> Tolerance for Newton-Raphson iterations (stop when increment falls below this) [nondim] real, public, parameter :: NR_TOLERANCE = 1e-12 contains @@ -79,17 +79,17 @@ subroutine regridding_set_ppolys(CS, densities, n0, h0, ppoly0_E, ppoly0_S, & ppoly0_coefs, degree, h_neglect, h_neglect_edge) type(interp_CS_type), intent(in) :: CS !< Interpolation control structure integer, intent(in) :: n0 !< Number of cells on source grid - real, dimension(n0), intent(in) :: densities !< Actual cell densities - real, dimension(n0), intent(in) :: h0 !< cell widths on source grid - real, dimension(n0,2), intent(inout) :: ppoly0_E !< Edge value of polynomial - real, dimension(n0,2), intent(inout) :: ppoly0_S !< Edge slope of polynomial - real, dimension(n0,DEGREE_MAX+1), intent(inout) :: ppoly0_coefs !< Coefficients of polynomial + real, dimension(n0), intent(in) :: densities !< Actual cell densities [A] + real, dimension(n0), intent(in) :: h0 !< cell widths on source grid [H] + real, dimension(n0,2), intent(inout) :: ppoly0_E !< Edge value of polynomial [A] + real, dimension(n0,2), intent(inout) :: ppoly0_S !< Edge slope of polynomial [A H-1] + real, dimension(n0,DEGREE_MAX+1), intent(inout) :: ppoly0_coefs !< Coefficients of polynomial [A] integer, intent(inout) :: degree !< The degree of the polynomials real, optional, intent(in) :: h_neglect !< A negligibly small width for the - !! purpose of cell reconstructions + !! purpose of cell reconstructions [H] !! in the same units as h0. real, optional, intent(in) :: h_neglect_edge !< A negligibly small width - !! for the purpose of edge value calculations + !! for the purpose of edge value calculations [H] !! in the same units as h0. ! Local variables logical :: extrapolate @@ -271,15 +271,15 @@ subroutine interpolate_grid( n0, h0, x0, ppoly0_E, ppoly0_coefs, & target_values, degree, n1, h1, x1, answers_2018 ) integer, intent(in) :: n0 !< Number of points on source grid integer, intent(in) :: n1 !< Number of points on target grid - real, dimension(n0), intent(in) :: h0 !< Thicknesses of source grid cells - real, dimension(n0+1), intent(in) :: x0 !< Source interface positions - real, dimension(n0,2), intent(in) :: ppoly0_E !< Edge values of interpolating polynomials + real, dimension(n0), intent(in) :: h0 !< Thicknesses of source grid cells [H] + real, dimension(n0+1), intent(in) :: x0 !< Source interface positions [H] + real, dimension(n0,2), intent(in) :: ppoly0_E !< Edge values of interpolating polynomials [A] real, dimension(n0,DEGREE_MAX+1), & - intent(in) :: ppoly0_coefs !< Coefficients of interpolating polynomials - real, dimension(n1+1), intent(in) :: target_values !< Target values of interfaces + intent(in) :: ppoly0_coefs !< Coefficients of interpolating polynomials [A] + real, dimension(n1+1), intent(in) :: target_values !< Target values of interfaces [A] integer, intent(in) :: degree !< Degree of interpolating polynomials - real, dimension(n1), intent(inout) :: h1 !< Thicknesses of target grid cells - real, dimension(n1+1), intent(inout) :: x1 !< Target interface positions + real, dimension(n1), intent(inout) :: h1 !< Thicknesses of target grid cells [H] + real, dimension(n1+1), intent(inout) :: x1 !< Target interface positions [H] logical, optional, intent(in) :: answers_2018 !< If true use older, less acccurate expressions. ! Local variables @@ -309,21 +309,22 @@ subroutine build_and_interpolate_grid(CS, densities, n0, h0, x0, target_values, type(interp_CS_type), intent(in) :: CS !< A control structure for regrid_interp integer, intent(in) :: n0 !< The number of points on the input grid integer, intent(in) :: n1 !< The number of points on the output grid - real, dimension(n0), intent(in) :: densities !< Input cell densities [kg m-3] - real, dimension(n1+1), intent(in) :: target_values !< Target values of interfaces - real, dimension(n0), intent(in) :: h0 !< Initial cell widths - real, dimension(n0+1), intent(in) :: x0 !< Source interface positions - real, dimension(n1), intent(inout) :: h1 !< Output cell widths - real, dimension(n1+1), intent(inout) :: x1 !< Target interface positions + real, dimension(n0), intent(in) :: densities !< Input cell densities [R ~> kg m-3] + real, dimension(n1+1), intent(in) :: target_values !< Target values of interfaces [R ~> kg m-3] + real, dimension(n0), intent(in) :: h0 !< Initial cell widths [H] + real, dimension(n0+1), intent(in) :: x0 !< Source interface positions [H] + real, dimension(n1), intent(inout) :: h1 !< Output cell widths [H] + real, dimension(n1+1), intent(inout) :: x1 !< Target interface positions [H] real, optional, intent(in) :: h_neglect !< A negligibly small width for the - !! purpose of cell reconstructions + !! purpose of cell reconstructions [H] !! in the same units as h0. real, optional, intent(in) :: h_neglect_edge !< A negligibly small width - !! for the purpose of edge value calculations + !! for the purpose of edge value calculations [H] !! in the same units as h0. - real, dimension(n0,2) :: ppoly0_E, ppoly0_S - real, dimension(n0,DEGREE_MAX+1) :: ppoly0_C + real, dimension(n0,2) :: ppoly0_E ! Polynomial edge values [R ~> kg m-3] + real, dimension(n0,2) :: ppoly0_S ! Polynomial edge slopes [R H-1] + real, dimension(n0,DEGREE_MAX+1) :: ppoly0_C ! Polynomial interpolant coeficients on the local 0-1 grid [R ~> kg m-3] integer :: degree call regridding_set_ppolys(CS, densities, n0, h0, ppoly0_E, ppoly0_S, ppoly0_C, & @@ -352,28 +353,28 @@ function get_polynomial_coordinate( N, h, x_g, ppoly_E, ppoly_coefs, & target_value, degree, answers_2018 ) result ( x_tgt ) ! Arguments integer, intent(in) :: N !< Number of grid cells - real, dimension(N), intent(in) :: h !< Grid cell thicknesses - real, dimension(N+1), intent(in) :: x_g !< Grid interface locations - real, dimension(N,2), intent(in) :: ppoly_E !< Edge values of interpolating polynomials - real, dimension(N,DEGREE_MAX+1), intent(in) :: ppoly_coefs !< Coefficients of interpolating polynomials - real, intent(in) :: target_value !< Target value to find position for + real, dimension(N), intent(in) :: h !< Grid cell thicknesses [H] + real, dimension(N+1), intent(in) :: x_g !< Grid interface locations [H] + real, dimension(N,2), intent(in) :: ppoly_E !< Edge values of interpolating polynomials [A] + real, dimension(N,DEGREE_MAX+1), intent(in) :: ppoly_coefs !< Coefficients of interpolating polynomials [A] + real, intent(in) :: target_value !< Target value to find position for [A] integer, intent(in) :: degree !< Degree of the interpolating polynomials logical, optional, intent(in) :: answers_2018 !< If true use older, less acccurate expressions. - real :: x_tgt !< The position of x_g at which target_value is found. + real :: x_tgt !< The position of x_g at which target_value is found [H] + ! Local variables - integer :: i, k ! loop indices - integer :: k_found ! index of target cell - integer :: iter - real :: xi0 ! normalized target coordinate - real, dimension(DEGREE_MAX) :: a ! polynomial coefficients + real :: xi0 ! normalized target coordinate [nondim] + real, dimension(DEGREE_MAX) :: a ! polynomial coefficients [A] real :: numerator real :: denominator - real :: delta ! Newton-Raphson increment - real :: x ! global target coordinate - real :: eps ! offset used to get away from - ! boundaries - real :: grad ! gradient during N-R iterations - logical :: use_2018_answers ! If true use older, less acccurate expressions. + real :: delta ! Newton-Raphson increment [nondim] +! real :: x ! global target coordinate + real :: eps ! offset used to get away from boundaries [nondim] + real :: grad ! gradient during N-R iterations [A] + integer :: i, k, iter ! loop indices + integer :: k_found ! index of target cell + character(len=200) :: mesg + logical :: use_2018_answers ! If true use older, less acccurate expressions. eps = NR_OFFSET k_found = -1 @@ -390,11 +391,9 @@ function get_polynomial_coordinate( N, h, x_g, ppoly_E, ppoly_coefs, & ! Since discontinuous edge values are allowed, we check whether the target ! value lies between two discontinuous edge values at interior interfaces do k = 2,N - if ( ( target_value >= ppoly_E(k-1,2) ) .AND. & - ( target_value <= ppoly_E(k,1) ) ) then + if ( ( target_value >= ppoly_E(k-1,2) ) .AND. ( target_value <= ppoly_E(k,1) ) ) then x_tgt = x_g(k) return ! return because there is no need to look further - exit endif enddo @@ -412,8 +411,7 @@ function get_polynomial_coordinate( N, h, x_g, ppoly_E, ppoly_coefs, & ! contains the target value. The variable k_found holds the index value ! of the cell where the taregt value lies. do k = 1,N - if ( ( target_value > ppoly_E(k,1) ) .AND. & - ( target_value < ppoly_E(k,2) ) ) then + if ( ( target_value > ppoly_E(k,1) ) .AND. ( target_value < ppoly_E(k,2) ) ) then k_found = k exit endif @@ -425,12 +423,10 @@ function get_polynomial_coordinate( N, h, x_g, ppoly_E, ppoly_coefs, & ! means there is a major problem with the interpolant. This needs to be ! reported. if ( k_found == -1 ) then - write(*,*) target_value, ppoly_E(1,1), ppoly_E(N,2) - write(*,*) 'Could not find target coordinate in ' //& - '"get_polynomial_coordinate". This is caused by an '//& - 'inconsistent interpolant (perhaps not monotonically '//& - 'increasing)' - call MOM_error( FATAL, 'Aborting execution' ) + write(mesg,*) 'Could not find target coordinate', target_value, 'in get_polynomial_coordinate. This is '//& + 'caused by an inconsistent interpolant (perhaps not monotonically increasing):', & + target_value, ppoly_E(1,1), ppoly_E(N,2) + call MOM_error( FATAL, mesg ) endif ! Reset all polynomial coefficients to 0 and copy those pertaining to @@ -440,18 +436,11 @@ function get_polynomial_coordinate( N, h, x_g, ppoly_E, ppoly_coefs, & a(i) = ppoly_coefs(k_found,i) enddo - ! Guess value to start Newton-Raphson iterations (middle of cell) + ! Guess the middle of the cell to start Newton-Raphson iterations xi0 = 0.5 - iter = 1 - delta = 1e10 ! Newton-Raphson iterations - do - ! break if converged or too many iterations taken - if ( ( iter > NR_ITERATIONS ) .OR. & - ( abs(delta) < NR_TOLERANCE ) ) then - exit - endif + do iter = 1,NR_ITERATIONS if (use_2018_answers) then numerator = a(1) + a(2)*xi0 + a(3)*xi0*xi0 + a(4)*xi0*xi0*xi0 + & @@ -487,7 +476,8 @@ function get_polynomial_coordinate( N, h, x_g, ppoly_E, ppoly_coefs, & if ( grad == 0.0 ) xi0 = xi0 - eps endif - iter = iter + 1 + ! break if converged or too many iterations taken + if ( abs(delta) < NR_TOLERANCE ) exit enddo ! end Newton-Raphson iterations x_tgt = x_g(k_found) + xi0 * h(k_found) diff --git a/src/framework/MOM_diag_mediator.F90 b/src/framework/MOM_diag_mediator.F90 index 421c23cf68..ceb782ce4b 100644 --- a/src/framework/MOM_diag_mediator.F90 +++ b/src/framework/MOM_diag_mediator.F90 @@ -145,7 +145,8 @@ module MOM_diag_mediator !> Stores all the remapping grids and the model's native space thicknesses type, public :: diag_grid_storage integer :: num_diag_coords !< Number of target coordinates - real, dimension(:,:,:), allocatable :: h_state !< Layer thicknesses in native space + real, dimension(:,:,:), allocatable :: h_state !< Layer thicknesses in native + !! space [H ~> m or kg m-2] type(diag_grids_type), dimension(:), allocatable :: diag_grids !< Primarily empty, except h field end type diag_grid_storage @@ -312,9 +313,9 @@ module MOM_diag_mediator !>@} ! Pointer to H, G and T&S needed for remapping - real, dimension(:,:,:), pointer :: h => null() !< The thicknesses needed for remapping - real, dimension(:,:,:), pointer :: T => null() !< The temperatures needed for remapping - real, dimension(:,:,:), pointer :: S => null() !< The salinities needed for remapping + real, dimension(:,:,:), pointer :: h => null() !< The thicknesses needed for remapping [H ~> m or kg m-2] + real, dimension(:,:,:), pointer :: T => null() !< The temperatures needed for remapping [degC] + real, dimension(:,:,:), pointer :: S => null() !< The salinities needed for remapping [ppt] type(EOS_type), pointer :: eqn_of_state => null() !< The equation of state type type(ocean_grid_type), pointer :: G => null() !< The ocean grid type type(verticalGrid_type), pointer :: GV => null() !< The model's vertical ocean grid @@ -324,7 +325,7 @@ module MOM_diag_mediator integer :: volume_cell_measure_dm_id = -1 #if defined(DEBUG) || defined(__DO_SAFETY_CHECKS__) - ! Keep a copy of h so that we know whether it has changed. If it has then + ! Keep a copy of h so that we know whether it has changed [H ~> m or kg m-2]. If it has then ! need the target grid for vertical remapping needs to have been updated. real, dimension(:,:,:), allocatable :: h_old #endif @@ -1525,8 +1526,7 @@ subroutine post_data_3d(diag_field_id, field, diag_cs, is_static, mask, alt_h) if (id_clock_diag_remap>0) call cpu_clock_begin(id_clock_diag_remap) allocate(remapped_field(size(field,1), size(field,2), diag%axes%nz)) - call diag_remap_do_remap(diag_cs%diag_remap_cs( & - diag%axes%vertical_coordinate_number), & + call diag_remap_do_remap(diag_cs%diag_remap_cs(diag%axes%vertical_coordinate_number), & diag_cs%G, diag_cs%GV, h_diag, staggered_in_x, staggered_in_y, & diag%axes%mask3d, diag_cs%missing_value, field, remapped_field) if (id_clock_diag_remap>0) call cpu_clock_end(id_clock_diag_remap) @@ -3202,7 +3202,7 @@ subroutine diag_update_remap_grids(diag_cs, alt_h, alt_T, alt_S) !! the current salinity ! Local variables integer :: i - real, dimension(:,:,:), pointer :: h_diag => NULL() + real, dimension(:,:,:), pointer :: h_diag => NULL() ! The layer thickneses for diagnostics [H ~> m or kg m-2] real, dimension(:,:,:), pointer :: T_diag => NULL(), S_diag => NULL() if (present(alt_h)) then @@ -3231,9 +3231,8 @@ subroutine diag_update_remap_grids(diag_cs, alt_h, alt_T, alt_S) endif do i=1, diag_cs%num_diag_coords - call diag_remap_update(diag_cs%diag_remap_cs(i), & - diag_cs%G, diag_cs%GV, diag_cs%US, h_diag, T_diag, S_diag, & - diag_cs%eqn_of_state) + call diag_remap_update(diag_cs%diag_remap_cs(i), diag_cs%G, diag_cs%GV, diag_cs%US, & + h_diag, T_diag, S_diag, diag_cs%eqn_of_state) enddo #if defined(DEBUG) || defined(__DO_SAFETY_CHECKS__) @@ -3518,7 +3517,7 @@ end subroutine diag_grid_storage_init !> Copy from the main diagnostic arrays to the grid storage as well as the native thicknesses subroutine diag_copy_diag_to_storage(grid_storage, h_state, diag) type(diag_grid_storage), intent(inout) :: grid_storage !< Structure containing a snapshot of the target grids - real, dimension(:,:,:), intent(in) :: h_state !< Current model thicknesses + real, dimension(:,:,:), intent(in) :: h_state !< Current model thicknesses [H ~> m or kg m-2] type(diag_ctrl), intent(in) :: diag !< Diagnostic control structure used as the contructor integer :: m diff --git a/src/framework/MOM_diag_remap.F90 b/src/framework/MOM_diag_remap.F90 index b61c10eb7e..cadd74950a 100644 --- a/src/framework/MOM_diag_remap.F90 +++ b/src/framework/MOM_diag_remap.F90 @@ -276,14 +276,14 @@ subroutine diag_remap_update(remap_cs, G, GV, US, h, T, S, eqn_of_state) type(ocean_grid_type), pointer :: G !< The ocean's grid type type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - real, dimension(:, :, :), intent(in) :: h !< New thickness - real, dimension(:, :, :), intent(in) :: T !< New T - real, dimension(:, :, :), intent(in) :: S !< New S + real, dimension(:, :, :), intent(in) :: h !< New thickness [H ~> m or kg m-2] + real, dimension(:, :, :), intent(in) :: T !< New temperatures [degC] + real, dimension(:, :, :), intent(in) :: S !< New salinities [ppt] type(EOS_type), pointer :: eqn_of_state !< A pointer to the equation of state ! Local variables - real, dimension(remap_cs%nz + 1) :: zInterfaces - real :: h_neglect, h_neglect_edge + real, dimension(remap_cs%nz + 1) :: zInterfaces ! Interface positions [H ~> m or kg m-2] + real :: h_neglect, h_neglect_edge ! Negligible thicknesses [H ~> m or kg m-2] integer :: i, j, k, nz ! Note that coordinateMode('LAYER') is never 'configured' so will @@ -326,16 +326,17 @@ subroutine diag_remap_update(remap_cs, G, GV, US, h, T, S, eqn_of_state) call build_sigma_column(get_sigma_CS(remap_cs%regrid_cs), & GV%Z_to_H*G%bathyT(i,j), sum(h(i,j,:)), zInterfaces) elseif (remap_cs%vertical_coord == coordinateMode('RHO')) then +!### I think that the conversion factor in the 2nd line should be GV%Z_to_H call build_rho_column(get_rho_CS(remap_cs%regrid_cs), G%ke, & US%Z_to_m*G%bathyT(i,j), h(i,j,:), T(i,j,:), S(i,j,:), & eqn_of_state, zInterfaces, h_neglect, h_neglect_edge) elseif (remap_cs%vertical_coord == coordinateMode('SLIGHT')) then ! call build_slight_column(remap_cs%regrid_cs,remap_cs%remap_cs, nz, & -! US%Z_to_m*G%bathyT(i,j), sum(h(i,j,:)), zInterfaces) +! GV%Z_to_H*G%bathyT(i,j), sum(h(i,j,:)), zInterfaces) call MOM_error(FATAL,"diag_remap_update: SLIGHT coordinate not coded for diagnostics yet!") elseif (remap_cs%vertical_coord == coordinateMode('HYCOM1')) then ! call build_hycom1_column(remap_cs%regrid_cs, nz, & -! US%Z_to_m*G%bathyT(i,j), sum(h(i,j,:)), zInterfaces) +! GV%Z_to_H*G%bathyT(i,j), sum(h(i,j,:)), zInterfaces) call MOM_error(FATAL,"diag_remap_update: HYCOM1 coordinate not coded for diagnostics yet!") endif remap_cs%h(i,j,:) = zInterfaces(1:nz) - zInterfaces(2:nz+1) From 24782fa85bdb631c5290fb2ad267aab6dee0f0c0 Mon Sep 17 00:00:00 2001 From: Andrew Shao Date: Tue, 17 Mar 2020 18:19:00 -0400 Subject: [PATCH 107/316] Move allocation of diagnostic arrays Originally, the diagnostic arrays were being allocated on the first call generating the diagnostic grid. This seems overly clunky because the size of the grids are known before that. This was also causing a segfault in updates to the new routine. The allocate statements for these arrays are now done right after the number of levels is known --- src/framework/MOM_diag_mediator.F90 | 4 ++++ src/framework/MOM_diag_remap.F90 | 2 -- 2 files changed, 4 insertions(+), 2 deletions(-) diff --git a/src/framework/MOM_diag_mediator.F90 b/src/framework/MOM_diag_mediator.F90 index 45376b628f..1d0d204354 100644 --- a/src/framework/MOM_diag_mediator.F90 +++ b/src/framework/MOM_diag_mediator.F90 @@ -456,6 +456,10 @@ subroutine set_axes_info(G, GV, US, param_file, diag_cs, set_vertical) ! For each possible diagnostic coordinate call diag_remap_configure_axes(diag_cs%diag_remap_cs(i), GV, US, param_file) + ! Allocate these arrays since the size of the diagnostic array is now known + allocate(diag_cs%diag_remap_cs(i)%h(G%isd:G%ied,G%jsd:G%jed, diag_cs%diag_remap_cs(i)%nz)) + allocate(diag_cs%diag_remap_cs(i)%h_extensive(G%isd:G%ied,G%jsd:G%jed, diag_cs%diag_remap_cs(i)%nz)) + ! This vertical coordinate has been configured so can be used. if (diag_remap_axes_configured(diag_cs%diag_remap_cs(i))) then diff --git a/src/framework/MOM_diag_remap.F90 b/src/framework/MOM_diag_remap.F90 index 000a3ce518..e4f8b410d2 100644 --- a/src/framework/MOM_diag_remap.F90 +++ b/src/framework/MOM_diag_remap.F90 @@ -307,8 +307,6 @@ subroutine diag_remap_update(remap_cs, G, GV, US, h, T, S, eqn_of_state, h_targe ! Initialize remapping and regridding on the first call call initialize_remapping(remap_cs%remap_cs, 'PPM_IH4', boundary_extrapolation=.false., & answers_2018=remap_cs%answers_2018) - allocate(remap_cs%h(G%isd:G%ied,G%jsd:G%jed, nz)) - allocate(remap_cs%h_extensive(G%isd:G%ied,G%jsd:G%jed, nz)) remap_cs%initialized = .true. endif From 6760d1e529f59664846a5ec562ed61354d66643a Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 18 Mar 2020 22:14:04 -0400 Subject: [PATCH 108/316] Corrected documented units in comments Corrected documented units in comments, corrected spelling errors in comments and removed unused variables. All answers are bitwise identical. --- src/core/MOM_PressureForce_Montgomery.F90 | 2 -- src/core/MOM_variables.F90 | 2 +- src/core/MOM_verticalGrid.F90 | 2 +- src/diagnostics/MOM_sum_output.F90 | 2 +- .../MOM_coord_initialization.F90 | 22 +++++++++---------- src/user/BFB_surface_forcing.F90 | 4 ++-- src/user/DOME2d_initialization.F90 | 1 - src/user/Phillips_initialization.F90 | 12 +++++----- src/user/benchmark_initialization.F90 | 2 +- src/user/dumbbell_surface_forcing.F90 | 7 +----- src/user/user_initialization.F90 | 8 +++---- 11 files changed, 27 insertions(+), 37 deletions(-) diff --git a/src/core/MOM_PressureForce_Montgomery.F90 b/src/core/MOM_PressureForce_Montgomery.F90 index c8662cba15..43de125701 100644 --- a/src/core/MOM_PressureForce_Montgomery.F90 +++ b/src/core/MOM_PressureForce_Montgomery.F90 @@ -32,8 +32,6 @@ module MOM_PressureForce_Mont logical :: tides !< If true, apply tidal momentum forcing. real :: Rho0 !< The density used in the Boussinesq !! approximation [kg m-3]. - real :: Rho_atm !< The assumed atmospheric density [kg m-3]. - !! By default, Rho_atm is 0. real :: GFS_scale !< Ratio between gravity applied to top interface and the !! gravitational acceleration of the planet [nondim]. !! Usually this ratio is 1. diff --git a/src/core/MOM_variables.F90 b/src/core/MOM_variables.F90 index 94cf169e29..09cbd14c60 100644 --- a/src/core/MOM_variables.F90 +++ b/src/core/MOM_variables.F90 @@ -204,7 +204,7 @@ module MOM_variables real, pointer, dimension(:,:) :: TKE_BBL => NULL() !< A term related to the bottom boundary layer source of turbulent kinetic !! energy, currently in [Z3 T-3 ~> m3 s-3], but may at some time be changed - !! to [kg Z3 m-3 T-3 ~> W m-2]. + !! to [R Z3 T-3 ~> W m-2]. real, pointer, dimension(:,:) :: & taux_shelf => NULL(), & !< The zonal stresses on the ocean under shelves [R Z L T-2 ~> Pa]. tauy_shelf => NULL() !< The meridional stresses on the ocean under shelves [R Z L T-2 ~> Pa]. diff --git a/src/core/MOM_verticalGrid.F90 b/src/core/MOM_verticalGrid.F90 index 093db28c07..0608499f92 100644 --- a/src/core/MOM_verticalGrid.F90 +++ b/src/core/MOM_verticalGrid.F90 @@ -29,7 +29,7 @@ module MOM_verticalGrid real :: mks_g_Earth !< The gravitational acceleration in unscaled MKS units [m s-2]. real :: g_Earth !< The gravitational acceleration [L2 Z-1 T-2 ~> m s-2]. real :: Rho0 !< The density used in the Boussinesq approximation or nominal - !! density used to convert depths into mass units [kg m-3]. + !! density used to convert depths into mass units [R ~> kg m-3]. ! Vertical coordinate descriptions for diagnostics and I/O character(len=40) :: zAxisUnits !< The units that vertical coordinates are written in diff --git a/src/diagnostics/MOM_sum_output.F90 b/src/diagnostics/MOM_sum_output.F90 index c7c8d81019..775cf39c22 100644 --- a/src/diagnostics/MOM_sum_output.F90 +++ b/src/diagnostics/MOM_sum_output.F90 @@ -386,7 +386,7 @@ subroutine write_energy(u, v, h, tv, day, n, G, GV, US, CS, tracer_CSp, OBC, dt_ PE_pt ! The potential energy at each point [J]. real, dimension(SZI_(G),SZJ_(G)) :: & Temp_int, Salt_int ! Layer and cell integrated heat and salt [J] and [g Salt]. - real :: HL2_to_kg ! A conversion factor form a thickness-volume to mass [kg H-1 L-2 ~> kg m-3 or 1] + real :: HL2_to_kg ! A conversion factor from a thickness-volume to mass [kg H-1 L-2 ~> kg m-3 or 1] real :: KE_scale_factor ! The combination of unit rescaling factors in the kinetic energy ! calculation [kg T2 H-1 L-2 s-2 ~> kg m-3 or nondim] real :: PE_scale_factor ! The combination of unit rescaling factors in the potential energy diff --git a/src/initialization/MOM_coord_initialization.F90 b/src/initialization/MOM_coord_initialization.F90 index b2519d47ad..63461df157 100644 --- a/src/initialization/MOM_coord_initialization.F90 +++ b/src/initialization/MOM_coord_initialization.F90 @@ -131,8 +131,8 @@ subroutine set_coord_from_gprime(Rlay, g_prime, GV, US, param_file) type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters ! Local variables - real :: g_int ! Reduced gravities across the internal interfaces [m s-2]. - real :: g_fs ! Reduced gravity across the free surface [m s-2]. + real :: g_int ! Reduced gravities across the internal interfaces [L2 Z-1 T-2 ~> m s-2]. + real :: g_fs ! Reduced gravity across the free surface [L2 Z-1 T-2 ~> m s-2]. character(len=40) :: mdl = "set_coord_from_gprime" ! This subroutine's name. integer :: k, nz nz = GV%ke @@ -165,9 +165,9 @@ subroutine set_coord_from_layer_density(Rlay, g_prime, GV, US, param_file) type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters ! Local variables - real :: g_fs ! Reduced gravity across the free surface [m s-2]. - real :: Rlay_Ref! The surface layer's target density [kg m-3]. - real :: RLay_range ! The range of densities [kg m-3]. + real :: g_fs ! Reduced gravity across the free surface [L2 Z-1 T-2 ~> m s-2]. + real :: Rlay_Ref! The surface layer's target density [R ~> kg m-3]. + real :: RLay_range ! The range of densities [R ~> kg m-3]. character(len=40) :: mdl = "set_coord_from_layer_density" ! This subroutine's name. integer :: k, nz nz = GV%ke @@ -213,8 +213,8 @@ subroutine set_coord_from_TS_ref(Rlay, g_prime, GV, US, param_file, eqn_of_state ! Local variables real :: T_ref ! Reference temperature real :: S_ref ! Reference salinity - real :: g_int ! Reduced gravities across the internal interfaces [m s-2]. - real :: g_fs ! Reduced gravity across the free surface [m s-2]. + real :: g_int ! Reduced gravities across the internal interfaces [L2 Z-1 T-2 ~> m s-2]. + real :: g_fs ! Reduced gravity across the free surface [L2 Z-1 T-2 ~> m s-2]. character(len=40) :: mdl = "set_coord_from_TS_ref" ! This subroutine's name. integer :: k, nz nz = GV%ke @@ -263,7 +263,7 @@ subroutine set_coord_from_TS_profile(Rlay, g_prime, GV, US, param_file, & real, intent(in) :: P_Ref !< The coordinate-density reference pressure [Pa]. ! Local variables real, dimension(GV%ke) :: T0, S0, Pref - real :: g_fs ! Reduced gravity across the free surface [m s-2]. + real :: g_fs ! Reduced gravity across the free surface [L2 Z-1 T-2 ~> m s-2]. integer :: k, nz character(len=40) :: mdl = "set_coord_from_TS_profile" ! This subroutine's name. character(len=200) :: filename, coord_file, inputdir ! Strings for file/path @@ -318,7 +318,7 @@ subroutine set_coord_from_TS_range(Rlay, g_prime, GV, US, param_file, & ! of the range to that in the lighter part of the range. ! Setting this greater than 1 increases the resolution for ! the denser water. - real :: g_fs ! Reduced gravity across the free surface [m s-2]. + real :: g_fs ! Reduced gravity across the free surface [L2 Z-1 T-2 ~> m s-2]. real :: a1, frac_dense, k_frac integer :: k, nz, k_light character(len=40) :: mdl = "set_coord_from_TS_range" ! This subroutine's name. @@ -390,7 +390,7 @@ subroutine set_coord_from_file(Rlay, g_prime, GV, US, param_file) type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters ! Local variables - real :: g_fs ! Reduced gravity across the free surface [m s-2]. + real :: g_fs ! Reduced gravity across the free surface [L2 Z-1 T-2 ~> m s-2]. integer :: k, nz character(len=40) :: mdl = "set_coord_from_file" ! This subroutine's name. character(len=40) :: coord_var @@ -486,7 +486,7 @@ subroutine set_coord_to_none(Rlay, g_prime, GV, US, param_file) type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters ! Local variables - real :: g_fs ! Reduced gravity across the free surface [m s-2]. + real :: g_fs ! Reduced gravity across the free surface [L2 Z-1 T-2 ~> m s-2]. character(len=40) :: mdl = "set_coord_to_none" ! This subroutine's name. integer :: k, nz nz = GV%ke diff --git a/src/user/BFB_surface_forcing.F90 b/src/user/BFB_surface_forcing.F90 index ec7f907fd1..70d89497da 100644 --- a/src/user/BFB_surface_forcing.F90 +++ b/src/user/BFB_surface_forcing.F90 @@ -98,7 +98,7 @@ subroutine BFB_buoyancy_forcing(state, fluxes, day, dt, G, US, CS) ! Set whichever fluxes are to be used here. Any fluxes that ! are always zero do not need to be changed here. do j=js,je ; do i=is,ie - ! Fluxes of fresh water through the surface are in units of [kg m-2 s-1] + ! Fluxes of fresh water through the surface are in units of [R Z T-1 ~> 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%lprec(i,j) = 0.0 * G%mask2dT(i,j) @@ -151,7 +151,7 @@ subroutine BFB_buoyancy_forcing(state, fluxes, day, dt, G, US, CS) Temp_restore = 0.0 do j=js,je ; do i=is,ie ! Set density_restore to an expression for the surface potential - ! density [kg m-3] that is being restored toward. + ! density [R ~> kg m-3] that is being restored toward. if (G%geoLatT(i,j) < CS%lfrslat) then Temp_restore = CS%SST_s elseif (G%geoLatT(i,j) > CS%lfrnlat) then diff --git a/src/user/DOME2d_initialization.F90 b/src/user/DOME2d_initialization.F90 index 642ed41d88..6d307f843a 100644 --- a/src/user/DOME2d_initialization.F90 +++ b/src/user/DOME2d_initialization.F90 @@ -365,7 +365,6 @@ subroutine DOME2d_initialize_sponges(G, GV, US, tv, param_file, use_ALE, CSp, AC ! Local variables real :: T(SZI_(G),SZJ_(G),SZK_(G)) ! A temporary array for temp [degC] real :: S(SZI_(G),SZJ_(G),SZK_(G)) ! A temporary array for salt [ppt] - real :: RHO(SZI_(G),SZJ_(G),SZK_(G)) ! A temporary array for RHO [kg m-3] real :: h(SZI_(G),SZJ_(G),SZK_(G)) ! A temporary array for thickness [H ~> m or kg m-2]. real :: eta(SZI_(G),SZJ_(G),SZK_(G)+1) ! A temporary array for thickness [Z ~> m] real :: Idamp(SZI_(G),SZJ_(G)) ! The inverse damping rate [T-1 ~> s-1]. diff --git a/src/user/Phillips_initialization.F90 b/src/user/Phillips_initialization.F90 index 5cd75725e3..dd7309265f 100644 --- a/src/user/Phillips_initialization.F90 +++ b/src/user/Phillips_initialization.F90 @@ -351,13 +351,11 @@ end subroutine Phillips_initialize_topography !! 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 [m s-1]. -!! v - Meridional velocity [m s-1]. -!! h - Layer thickness in m. (Must be positive.) -!! D - Basin depth in m. (Must be positive.) -!! f - The Coriolis parameter [s-1]. -!! g - The reduced gravity at each interface [m s-2] -!! Rlay - Layer potential density (coordinate variable) [kg m-3]. +!! u - Zonal velocity [L T-1 ~> m s-1]. +!! v - Meridional velocity [L T-1 ~> m s-1]. +!! h - Layer thickness [H ~> m or kg m-2] (must be positive) +!! D - Basin depth [Z ~> m] (positive downward) +!! f - The Coriolis parameter [T-1 ~> s-1]. !! If ENABLE_THERMODYNAMICS is defined: !! T - Temperature [degC]. !! S - Salinity [ppt]. diff --git a/src/user/benchmark_initialization.F90 b/src/user/benchmark_initialization.F90 index 3478415c60..5641035ded 100644 --- a/src/user/benchmark_initialization.F90 +++ b/src/user/benchmark_initialization.F90 @@ -232,7 +232,7 @@ subroutine benchmark_init_temperature_salinity(T, S, G, GV, US, param_file, & !! only read parameters without changing h. ! Local variables real :: T0(SZK_(G)), S0(SZK_(G)) - real :: pres(SZK_(G)) ! Reference pressure [kg m-3]. + real :: pres(SZK_(G)) ! Reference pressure [Pa]. real :: drho_dT(SZK_(G)) ! Derivative of density with temperature [R degC-1 ~> kg m-3 degC-1]. real :: drho_dS(SZK_(G)) ! Derivative of density with salinity [R ppt-1 ~> kg m-3 ppt-1]. real :: rho_guess(SZK_(G)) ! Potential density at T0 & S0 [R ~> kg m-3]. diff --git a/src/user/dumbbell_surface_forcing.F90 b/src/user/dumbbell_surface_forcing.F90 index 63f8009235..c1f615fe2a 100644 --- a/src/user/dumbbell_surface_forcing.F90 +++ b/src/user/dumbbell_surface_forcing.F90 @@ -63,9 +63,6 @@ subroutine dumbbell_buoyancy_forcing(state, fluxes, day, dt, G, US, CS) ! Local variables real :: Temp_restore ! The temperature that is being restored toward [degC]. real :: Salin_restore ! The salinity that is being restored toward [ppt]. - real :: density_restore ! The potential density that is being restored - ! toward [kg m-3]. - real :: rhoXcp ! The mean density times the heat capacity [J m-3 degC-1]. integer :: i, j, is, ie, js, je integer :: isd, ied, jsd, jed @@ -97,7 +94,7 @@ subroutine dumbbell_buoyancy_forcing(state, fluxes, day, dt, G, US, CS) ! Set whichever fluxes are to be used here. Any fluxes that ! are always zero do not need to be changed here. do j=js,je ; do i=is,ie - ! Fluxes of fresh water through the surface are in units of [kg m-2 s-1] + ! Fluxes of fresh water through the surface are in units of [R Z T-1 ~> 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%lprec(i,j) = 0.0 * G%mask2dT(i,j) @@ -121,8 +118,6 @@ subroutine dumbbell_buoyancy_forcing(state, fluxes, day, dt, G, US, CS) if (CS%use_temperature .and. CS%restorebuoy) then do j=js,je ; do i=is,ie - ! Set density_restore to an expression for the surface potential - ! density [kg m-3] that is being restored toward. if (CS%forcing_mask(i,j)>0.) then fluxes%vprec(i,j) = - (G%mask2dT(i,j) * (CS%Rho0*CS%Flux_const)) * & ((CS%S_restore(i,j) - state%SSS(i,j)) / (0.5 * (CS%S_restore(i,j) + state%SSS(i,j)))) diff --git a/src/user/user_initialization.F90 b/src/user/user_initialization.F90 index 7db78f2454..55c609802e 100644 --- a/src/user/user_initialization.F90 +++ b/src/user/user_initialization.F90 @@ -242,10 +242,10 @@ end subroutine write_user_log !! !! 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 +!! current time of the simulation. The fields which might be initialized !! here are: -!! - u - Zonal velocity [m s-1]. -!! - v - Meridional velocity [m s-1]. +!! - u - Zonal velocity [Z T-1 ~> m s-1]. +!! - v - Meridional velocity [Z T-1 ~> m s-1]. !! - h - Layer thickness [H ~> m or kg m-2]. (Must be positive.) !! - G%bathyT - Basin depth [Z ~> m]. (Must be positive.) !! - G%CoriolisBu - The Coriolis parameter [T-1 ~> s-1]. @@ -255,7 +255,7 @@ end subroutine write_user_log !! - T - Temperature [degC]. !! - S - Salinity [psu]. !! If BULKMIXEDLAYER is defined: -!! - Rml - Mixed layer and buffer layer potential densities [kg m-3]. +!! - Rml - Mixed layer and buffer layer potential densities [R ~> 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 From 2c2cf5644664f38201a2659ceba047179dfe2a9f Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 18 Mar 2020 22:16:24 -0400 Subject: [PATCH 109/316] Rescaled diagnostic calculations Rescaled the calculations of diagnostics of the integrated mass transports, column integrated temperature and salinity, cell thicknesses and column mass for dimensional consistency testing. All answers are bitwise identical. --- src/diagnostics/MOM_diagnostics.F90 | 86 +++++++++++++++-------------- 1 file changed, 46 insertions(+), 40 deletions(-) diff --git a/src/diagnostics/MOM_diagnostics.F90 b/src/diagnostics/MOM_diagnostics.F90 index 284322f072..84c4011718 100644 --- a/src/diagnostics/MOM_diagnostics.F90 +++ b/src/diagnostics/MOM_diagnostics.F90 @@ -228,6 +228,7 @@ subroutine calculate_diagnostic_fields(u, v, h, uh, vh, tv, ADp, CDp, p_surf, & real :: Rcv(SZI_(G),SZJ_(G),SZK_(G)) ! Coordinate variable potential density [R ~> kg m-3]. real :: work_3d(SZI_(G),SZJ_(G),SZK_(G)) ! A 3-d temporary work array. real :: work_2d(SZI_(G),SZJ_(G)) ! A 2-d temporary work array. + real :: rho_in_situ(SZI_(G)) ! In situ density [R ~> kg m-3] ! tmp array for surface properties real :: surface_field(SZI_(G),SZJ_(G)) @@ -328,17 +329,17 @@ subroutine calculate_diagnostic_fields(u, v, h, uh, vh, tv, ADp, CDp, p_surf, & ! diagnose thickness/volumes of grid cells [m] if (CS%id_thkcello>0 .or. CS%id_volcello>0) then if (GV%Boussinesq) then ! thkcello = h for Boussinesq - if (CS%id_thkcello > 0) then ; if (GV%H_to_m == 1.0) then + if (CS%id_thkcello > 0) then ; if (GV%H_to_Z == 1.0) then call post_data(CS%id_thkcello, h, CS%diag) else do k=1,nz; do j=js,je ; do i=is,ie - work_3d(i,j,k) = GV%H_to_m*h(i,j,k) + work_3d(i,j,k) = GV%H_to_Z*h(i,j,k) enddo ; enddo ; enddo call post_data(CS%id_thkcello, work_3d, CS%diag) endif ; endif if (CS%id_volcello > 0) then ! volcello = h*area for Boussinesq do k=1,nz; do j=js,je ; do i=is,ie - work_3d(i,j,k) = ( GV%H_to_m*h(i,j,k) ) * US%L_to_m**2*G%areaT(i,j) + work_3d(i,j,k) = ( GV%H_to_Z*h(i,j,k) ) * US%Z_to_m*US%L_to_m**2*G%areaT(i,j) enddo ; enddo ; enddo call post_data(CS%id_volcello, work_3d, CS%diag) endif @@ -357,11 +358,11 @@ subroutine calculate_diagnostic_fields(u, v, h, uh, vh, tv, ADp, CDp, p_surf, & do i=is,ie ! Pressure for EOS at the layer center [Pa] pressure_1d(i) = pressure_1d(i) + 0.5*GV%H_to_Pa*h(i,j,k) enddo - ! Store in-situ density [kg m-3] in work_3d + ! Store in-situ density [R ~> kg m-3] in work_3d call calculate_density(tv%T(:,j,k),tv%S(:,j,k), pressure_1d, & - work_3d(:,j,k), is, ie-is+1, tv%eqn_of_state) + rho_in_situ, is, ie-is+1, tv%eqn_of_state, scale=US%kg_m3_to_R) do i=is,ie ! Cell thickness = dz = dp/(g*rho) (meter); store in work_3d - work_3d(i,j,k) = (GV%H_to_kg_m2*h(i,j,k)) / work_3d(i,j,k) + work_3d(i,j,k) = (GV%H_to_RZ*h(i,j,k)) / rho_in_situ(i) enddo do i=is,ie ! Pressure for EOS at the bottom interface [Pa] pressure_1d(i) = pressure_1d(i) + 0.5*GV%H_to_Pa*h(i,j,k) @@ -371,7 +372,7 @@ subroutine calculate_diagnostic_fields(u, v, h, uh, vh, tv, ADp, CDp, p_surf, & if (CS%id_thkcello > 0) call post_data(CS%id_thkcello, work_3d, CS%diag) if (CS%id_volcello > 0) then do k=1,nz; do j=js,je ; do i=is,ie ! volcello = dp/(rho*g)*area for non-Boussinesq - work_3d(i,j,k) = US%L_to_m**2*G%areaT(i,j) * work_3d(i,j,k) + work_3d(i,j,k) = US%Z_to_m*US%L_to_m**2*G%areaT(i,j) * work_3d(i,j,k) enddo ; enddo ; enddo call post_data(CS%id_volcello, work_3d, CS%diag) endif @@ -465,7 +466,7 @@ subroutine calculate_diagnostic_fields(u, v, h, uh, vh, tv, ADp, CDp, p_surf, & !$OMP parallel do default(shared) do k=1,nz ; do j=js-1,je+1 call calculate_density(tv%T(:,j,k), tv%S(:,j,k), pressure_1d, & - Rcv(:,j,k), is-1, ie-is+3, tv%eqn_of_state, scale=US%kg_m3_to_R) + Rcv(:,j,k), is-1, ie-is+3, tv%eqn_of_state , scale=US%kg_m3_to_R) enddo ; enddo else ! Rcv should not be used much in this case, so fill in sensible values. do k=1,nz ; do j=js-1,je+1 ; do i=is-1,ie+1 @@ -778,7 +779,7 @@ subroutine calculate_vertical_integrals(h, tv, p_surf, G, GV, US, CS) z_top, & ! Height of the top of a layer or the ocean [Z ~> m]. z_bot, & ! Height of the bottom of a layer (for id_mass) or the ! (positive) depth of the ocean (for id_col_ht) [Z ~> m]. - mass, & ! integrated mass of the water column [kg m-2]. For + mass, & ! integrated mass of the water column [R Z ~> kg m-2]. For ! non-Boussinesq models this is rho*dz. For Boussinesq ! models, this is either the integral of in-situ density ! (rho*dz for col_mass) or reference density (Rho_0*dz for mass_wt). @@ -788,7 +789,7 @@ subroutine calculate_vertical_integrals(h, tv, p_surf, G, GV, US, CS) dpress, & ! Change in hydrostatic pressure across a layer [Pa]. tr_int ! vertical integral of a tracer times density, ! (Rho_0 in a Boussinesq model) [TR kg m-2]. - real :: IG_Earth ! Inverse of gravitational acceleration [s2 m-1]. + real :: IG_Earth ! Inverse of gravitational acceleration [s2 Z m-2 ~> s2 m-1]. integer :: i, j, k, is, ie, js, je, nz is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke @@ -796,7 +797,7 @@ subroutine calculate_vertical_integrals(h, tv, p_surf, G, GV, US, CS) if (CS%id_mass_wt > 0) then do j=js,je ; do i=is,ie ; mass(i,j) = 0.0 ; enddo ; enddo do k=1,nz ; do j=js,je ; do i=is,ie - mass(i,j) = mass(i,j) + GV%H_to_kg_m2*h(i,j,k) + mass(i,j) = mass(i,j) + GV%H_to_RZ*h(i,j,k) enddo ; enddo ; enddo call post_data(CS%id_mass_wt, mass, CS%diag) endif @@ -804,7 +805,7 @@ subroutine calculate_vertical_integrals(h, tv, p_surf, G, GV, US, CS) if (CS%id_temp_int > 0) then do j=js,je ; do i=is,ie ; tr_int(i,j) = 0.0 ; enddo ; enddo do k=1,nz ; do j=js,je ; do i=is,ie - tr_int(i,j) = tr_int(i,j) + (GV%H_to_kg_m2*h(i,j,k))*tv%T(i,j,k) + tr_int(i,j) = tr_int(i,j) + (GV%H_to_RZ*h(i,j,k))*tv%T(i,j,k) enddo ; enddo ; enddo call post_data(CS%id_temp_int, tr_int, CS%diag) endif @@ -812,7 +813,7 @@ subroutine calculate_vertical_integrals(h, tv, p_surf, G, GV, US, CS) if (CS%id_salt_int > 0) then do j=js,je ; do i=is,ie ; tr_int(i,j) = 0.0 ; enddo ; enddo do k=1,nz ; do j=js,je ; do i=is,ie - tr_int(i,j) = tr_int(i,j) + (GV%H_to_kg_m2*h(i,j,k))*tv%S(i,j,k) + tr_int(i,j) = tr_int(i,j) + (GV%H_to_RZ*h(i,j,k))*tv%S(i,j,k) enddo ; enddo ; enddo call post_data(CS%id_salt_int, tr_int, CS%diag) endif @@ -830,7 +831,7 @@ subroutine calculate_vertical_integrals(h, tv, p_surf, G, GV, US, CS) do j=js,je ; do i=is,ie ; mass(i,j) = 0.0 ; enddo ; enddo if (GV%Boussinesq) then if (associated(tv%eqn_of_state)) then - IG_Earth = 1.0 / GV%mks_g_Earth + IG_Earth = 1.0 / (US%Z_to_m*GV%mks_g_Earth) ! do j=js,je ; do i=is,ie ; z_bot(i,j) = -P_SURF(i,j)/GV%H_to_Pa ; enddo ; enddo do j=G%jscB,G%jecB+1 ; do i=G%iscB,G%iecB+1 z_bot(i,j) = 0.0 @@ -844,17 +845,17 @@ subroutine calculate_vertical_integrals(h, tv, p_surf, G, GV, US, CS) z_top, z_bot, 0.0, US%R_to_kg_m3*GV%Rho0, GV%mks_g_Earth*US%Z_to_m, & G%HI, G%HI, tv%eqn_of_state, dpress) do j=js,je ; do i=is,ie - mass(i,j) = mass(i,j) + dpress(i,j) * IG_Earth + mass(i,j) = mass(i,j) + dpress(i,j) * US%kg_m3_to_R*IG_Earth enddo ; enddo enddo else do k=1,nz ; do j=js,je ; do i=is,ie - mass(i,j) = mass(i,j) + (GV%H_to_m*US%R_to_kg_m3*GV%Rlay(k))*h(i,j,k) + mass(i,j) = mass(i,j) + (GV%H_to_Z*GV%Rlay(k))*h(i,j,k) enddo ; enddo ; enddo endif else do k=1,nz ; do j=js,je ; do i=is,ie - mass(i,j) = mass(i,j) + GV%H_to_kg_m2*h(i,j,k) + mass(i,j) = mass(i,j) + GV%H_to_RZ*h(i,j,k) enddo ; enddo ; enddo endif if (CS%id_col_mass > 0) then @@ -866,7 +867,7 @@ subroutine calculate_vertical_integrals(h, tv, p_surf, G, GV, US, CS) ! 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%mks_g_Earth + btm_pres(i,j) = US%RZ_to_kg_m2*mass(i,j) * GV%mks_g_Earth if (associated(p_surf)) then btm_pres(i,j) = btm_pres(i,j) + p_surf(i,j) endif @@ -1353,20 +1354,20 @@ subroutine post_transport_diagnostics(G, GV, US, uhtr, vhtr, h, IDs, diag_pre_dy type(tracer_registry_type), pointer :: Reg !< Pointer to the tracer registry ! Local variables - real, dimension(SZIB_(G), SZJ_(G)) :: umo2d ! Diagnostics of integrated mass transport [kg s-1] - real, dimension(SZI_(G), SZJB_(G)) :: vmo2d ! Diagnostics of integrated mass transport [kg s-1] - real, dimension(SZIB_(G), SZJ_(G), SZK_(G)) :: umo ! Diagnostics of layer mass transport [kg s-1] - real, dimension(SZI_(G), SZJB_(G), SZK_(G)) :: vmo ! Diagnostics of layer mass transport [kg s-1] + real, dimension(SZIB_(G), SZJ_(G)) :: umo2d ! Diagnostics of integrated mass transport [R Z L2 T-1 ~> kg s-1] + real, dimension(SZI_(G), SZJB_(G)) :: vmo2d ! Diagnostics of integrated mass transport [R Z L2 T-1 ~> kg s-1] + real, dimension(SZIB_(G), SZJ_(G), SZK_(G)) :: umo ! Diagnostics of layer mass transport [R Z L2 T-1 ~> kg s-1] + real, dimension(SZI_(G), SZJB_(G), SZK_(G)) :: vmo ! Diagnostics of layer mass transport [R Z L2 T-1 ~> kg s-1] real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: h_tend ! Change in layer thickness due to dynamics ! [H s-1 ~> m s-1 or kg m-2 s-1]. real :: Idt ! The inverse of the time interval [T-1 ~> s-1] - real :: H_to_kg_m2_dt ! A conversion factor from accumulated transports to fluxes - ! [kg L-2 H-1 T-1 ~> kg m-3 s-1 or s-1]. + real :: H_to_RZ_dt ! A conversion factor from accumulated transports to fluxes + ! [R Z H-1 T-1 ~> kg m-3 s-1 or s-1]. integer :: i, j, k, is, ie, js, je, nz is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke Idt = 1. / dt_trans - H_to_kg_m2_dt = GV%H_to_kg_m2 * US%L_to_m**2 * US%s_to_T * Idt + H_to_RZ_dt = GV%H_to_RZ * Idt call diag_save_grids(diag) call diag_copy_storage_to_diag(diag, diag_pre_dyn) @@ -1374,28 +1375,28 @@ subroutine post_transport_diagnostics(G, GV, US, uhtr, vhtr, h, IDs, diag_pre_dy if (IDs%id_umo_2d > 0) then umo2d(:,:) = 0.0 do k=1,nz ; do j=js,je ; do I=is-1,ie - umo2d(I,j) = umo2d(I,j) + uhtr(I,j,k) * H_to_kg_m2_dt + umo2d(I,j) = umo2d(I,j) + uhtr(I,j,k) * H_to_RZ_dt enddo ; enddo ; enddo call post_data(IDs%id_umo_2d, umo2d, diag) endif if (IDs%id_umo > 0) then ! 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 + umo(I,j,k) = uhtr(I,j,k) * H_to_RZ_dt enddo ; enddo ; enddo call post_data(IDs%id_umo, umo, diag, alt_h = diag_pre_dyn%h_state) endif if (IDs%id_vmo_2d > 0) then vmo2d(:,:) = 0.0 do k=1,nz ; do J=js-1,je ; do i=is,ie - vmo2d(i,J) = vmo2d(i,J) + vhtr(i,J,k) * H_to_kg_m2_dt + vmo2d(i,J) = vmo2d(i,J) + vhtr(i,J,k) * H_to_RZ_dt enddo ; enddo ; enddo call post_data(IDs%id_vmo_2d, vmo2d, diag) endif if (IDs%id_vmo > 0) then ! 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 + vmo(i,J,k) = vhtr(i,J,k) * H_to_RZ_dt enddo ; enddo ; enddo call post_data(IDs%id_vmo, vmo, diag, alt_h = diag_pre_dyn%h_state) endif @@ -1501,10 +1502,11 @@ subroutine MOM_diagnostics_init(MIS, ADp, CDp, Time, G, GV, US, param_file, diag diag, 'Mass of liquid ocean', 'kg', standard_name='sea_water_mass') CS%id_thkcello = register_diag_field('ocean_model', 'thkcello', diag%axesTL, Time, & - long_name = 'Cell Thickness', standard_name='cell_thickness', units='m', v_extensive=.true.) + long_name = 'Cell Thickness', standard_name='cell_thickness', & + units='m', conversion=US%Z_to_m, v_extensive=.true.) CS%id_h_pre_sync = register_diag_field('ocean_model', 'h_pre_sync', diag%axesTL, Time, & - long_name = 'Cell thickness from the previous timestep', units='m', & - v_extensive=.true., conversion=GV%H_to_m) + long_name = 'Cell thickness from the previous timestep', & + units='m', conversion=GV%H_to_m, v_extensive=.true.) ! Note that CS%id_volcello would normally be registered here but because it is a "cell measure" and ! must be registered first. We earlier stored the handle of volcello but need it here for posting @@ -1707,24 +1709,24 @@ subroutine MOM_diagnostics_init(MIS, ADp, CDp, Time, G, GV, US, param_file, diag endif CS%id_mass_wt = register_diag_field('ocean_model', 'mass_wt', diag%axesT1, Time, & - 'The column mass for calculating mass-weighted average properties', 'kg m-2') + 'The column mass for calculating mass-weighted average properties', 'kg m-2', conversion=US%RZ_to_kg_m2) if (use_temperature) then CS%id_temp_int = register_diag_field('ocean_model', 'temp_int', diag%axesT1, Time, & - 'Density weighted column integrated potential temperature', 'degC kg m-2', & + 'Density weighted column integrated potential temperature', 'degC kg m-2', conversion=US%RZ_to_kg_m2, & cmor_field_name='opottempmint', & cmor_long_name='integral_wrt_depth_of_product_of_sea_water_density_and_potential_temperature',& cmor_standard_name='Depth integrated density times potential temperature') CS%id_salt_int = register_diag_field('ocean_model', 'salt_int', diag%axesT1, Time, & - 'Density weighted column integrated salinity', 'psu kg m-2', & + 'Density weighted column integrated salinity', 'psu kg m-2', conversion=US%RZ_to_kg_m2, & cmor_field_name='somint', & cmor_long_name='integral_wrt_depth_of_product_of_sea_water_density_and_salinity',& cmor_standard_name='Depth integrated density times salinity') endif CS%id_col_mass = register_diag_field('ocean_model', 'col_mass', diag%axesT1, Time, & - 'The column integrated in situ density', 'kg m-2') + 'The column integrated in situ density', 'kg m-2', conversion=US%RZ_to_kg_m2) CS%id_col_ht = register_diag_field('ocean_model', 'col_height', diag%axesT1, Time, & 'The height of the water column', 'm', conversion=US%Z_to_m) @@ -1841,16 +1843,20 @@ subroutine register_transport_diags(Time, G, GV, US, IDs, diag) 'Accumulated meridional thickness fluxes to advect tracers', 'kg', & x_cell_method='sum', v_extensive=.true., conversion=H_convert*US%L_to_m**2) IDs%id_umo = register_diag_field('ocean_model', 'umo', & - diag%axesCuL, Time, 'Ocean Mass X Transport', 'kg s-1', & + diag%axesCuL, Time, 'Ocean Mass X Transport', & + 'kg s-1', conversion=US%RZ_T_to_kg_m2s*US%L_to_m**2, & standard_name='ocean_mass_x_transport', y_cell_method='sum', v_extensive=.true.) IDs%id_vmo = register_diag_field('ocean_model', 'vmo', & - diag%axesCvL, Time, 'Ocean Mass Y Transport', 'kg s-1', & + diag%axesCvL, Time, 'Ocean Mass Y Transport', & + 'kg s-1', conversion=US%RZ_T_to_kg_m2s*US%L_to_m**2, & standard_name='ocean_mass_y_transport', x_cell_method='sum', v_extensive=.true.) IDs%id_umo_2d = register_diag_field('ocean_model', 'umo_2d', & - diag%axesCu1, Time, 'Ocean Mass X Transport Vertical Sum', 'kg s-1', & + diag%axesCu1, Time, 'Ocean Mass X Transport Vertical Sum', & + 'kg s-1', conversion=US%RZ_T_to_kg_m2s*US%L_to_m**2, & standard_name='ocean_mass_x_transport_vertical_sum', y_cell_method='sum') IDs%id_vmo_2d = register_diag_field('ocean_model', 'vmo_2d', & - diag%axesCv1, Time, 'Ocean Mass Y Transport Vertical Sum', 'kg s-1', & + diag%axesCv1, Time, 'Ocean Mass Y Transport Vertical Sum', & + 'kg s-1', conversion=US%RZ_T_to_kg_m2s*US%L_to_m**2, & standard_name='ocean_mass_y_transport_vertical_sum', x_cell_method='sum') IDs%id_dynamics_h = register_diag_field('ocean_model','dynamics_h', & diag%axesTl, Time, 'Change in layer thicknesses due to horizontal dynamics', & From 43ba3bcd7706c975af64532d4f7e227104899952 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 18 Mar 2020 22:19:10 -0400 Subject: [PATCH 110/316] +Rescaled density derivatives in full_convection Rescaled the density derivatives used in full_convection, smoothed_dRdT_dRdS and user_change_diff. This change requires that new unit_scale_type arguments be passed to these three subroutines. All answers are bitwise identical. --- .../vertical/MOM_full_convection.F90 | 29 ++++++++++--------- .../vertical/MOM_set_diffusivity.F90 | 4 +-- src/user/user_change_diffusivity.F90 | 24 +++++++-------- 3 files changed, 30 insertions(+), 27 deletions(-) diff --git a/src/parameterizations/vertical/MOM_full_convection.F90 b/src/parameterizations/vertical/MOM_full_convection.F90 index 5fd3d67b36..daf41a1ad3 100644 --- a/src/parameterizations/vertical/MOM_full_convection.F90 +++ b/src/parameterizations/vertical/MOM_full_convection.F90 @@ -4,9 +4,10 @@ module MOM_full_convection ! This file is part of MOM6. See LICENSE.md for the license. use MOM_grid, only : ocean_grid_type +use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : thermo_var_ptrs use MOM_verticalGrid, only : verticalGrid_type -use MOM_EOS, only : int_specific_vol_dp, calculate_density_derivs +use MOM_EOS, only : calculate_density_derivs implicit none ; private @@ -17,10 +18,11 @@ module MOM_full_convection contains !> Calculate new temperatures and salinities that have been subject to full convective mixing. -subroutine full_convection(G, GV, h, tv, T_adj, S_adj, p_surf, Kddt_smooth, & +subroutine full_convection(G, GV, US, h, tv, T_adj, S_adj, p_surf, Kddt_smooth, & Kddt_convect, halo) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various @@ -38,8 +40,8 @@ subroutine full_convection(G, GV, h, tv, T_adj, S_adj, p_surf, Kddt_smooth, & ! Local variables real, dimension(SZI_(G),SZK_(G)+1) :: & - drho_dT, & ! The derivatives of density with temperature and - drho_dS ! salinity [kg m-3 degC-1] and [kg m-3 ppt-1]. + dRho_dT, & ! The derivative of density with temperature [R degC-1 ~> kg m-3 degC-1] + dRho_dS ! The derivative of density with salinity [R ppt-1 ~> kg m-3 ppt-1]. real :: h_neglect, h0 ! A thickness that is so small it is usually lost ! in roundoff and can be neglected [H ~> m or kg m-2]. ! logical :: use_EOS ! If true, density is calculated from T & S using an equation of state. @@ -107,7 +109,7 @@ subroutine full_convection(G, GV, h, tv, T_adj, S_adj, p_surf, Kddt_smooth, & ! These would be Te_b(:,:) = tv%T(:,j,:), etc., but the values are not used Te_b(:,:) = 0.0 ; Se_b(:,:) = 0.0 - call smoothed_dRdT_dRdS(h, tv, Kddt_smooth, drho_dT, drho_dS, G, GV, j, p_surf, halo) + call smoothed_dRdT_dRdS(h, tv, Kddt_smooth, dRho_dT, dRho_dS, G, GV, US, j, p_surf, halo) do i=is,ie do_i(i) = (G%mask2dT(i,j) > 0.0) @@ -281,8 +283,8 @@ end subroutine full_convection !! above and below, including partial calculations from a tridiagonal solver. function is_unstable(dRho_dT, dRho_dS, h_a, h_b, mix_A, mix_B, T_a, T_b, S_a, S_b, & Te_aa, Te_bb, Se_aa, Se_bb, d_A, d_B) - real, intent(in) :: dRho_dT !< The derivative of in situ density with temperature [kg m-3 degC-1] - real, intent(in) :: dRho_dS !< The derivative of in situ density with salinity [kg m-3 ppt-1] + real, intent(in) :: dRho_dT !< The derivative of in situ density with temperature [R degC-1 ~> kg m-3 degC-1] + real, intent(in) :: dRho_dS !< The derivative of in situ density with salinity [R ppt-1 ~> kg m-3 ppt-1] real, intent(in) :: h_a !< The thickness of the layer above [H ~> m or kg m-2] real, intent(in) :: h_b !< The thickness of the layer below [H ~> m or kg m-2] real, intent(in) :: mix_A !< The time integrated mixing rate of the interface above [H ~> m or kg m-2] @@ -317,7 +319,7 @@ end function is_unstable !> Returns the partial derivatives of locally referenced potential density with !! temperature and salinity after the properties have been smoothed with a small !! constant diffusivity. -subroutine smoothed_dRdT_dRdS(h, tv, Kddt, dR_dT, dR_dS, G, GV, j, p_surf, halo) +subroutine smoothed_dRdT_dRdS(h, tv, Kddt, dR_dT, dR_dS, G, GV, US, j, p_surf, halo) 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)), & @@ -327,10 +329,11 @@ subroutine smoothed_dRdT_dRdS(h, tv, Kddt, dR_dT, dR_dS, G, GV, j, p_surf, halo) real, intent(in) :: Kddt !< A diffusivity times a time increment [H2 ~> m2 or kg2 m-4]. real, dimension(SZI_(G),SZK_(G)+1), & intent(out) :: dR_dT !< Derivative of locally referenced - !! potential density with temperature [kg m-3 degC-1] + !! potential density with temperature [R degC-1 ~> kg m-3 degC-1] real, dimension(SZI_(G),SZK_(G)+1), & intent(out) :: dR_dS !< Derivative of locally referenced - !! potential density with salinity [kg m-3 ppt-1] + !! potential density with salinity [R degC-1 ~> kg m-3 ppt-1] + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type integer, intent(in) :: j !< The j-point to work on. real, dimension(:,:), pointer :: p_surf !< The pressure at the ocean surface [Pa]. integer, optional, intent(in) :: halo !< Halo width over which to compute @@ -405,7 +408,7 @@ subroutine smoothed_dRdT_dRdS(h, tv, Kddt, dR_dT, dR_dS, G, GV, j, p_surf, halo) do i=is,ie ; pres(i) = 0.0 ; enddo endif call calculate_density_derivs(T_f(:,1), S_f(:,1), pres, dR_dT(:,1), dR_dS(:,1), & - is-G%isd+1, ie-is+1, tv%eqn_of_state) + is-G%isd+1, ie-is+1, tv%eqn_of_state, scale=US%kg_m3_to_R) do i=is,ie ; pres(i) = pres(i) + h(i,j,1)*GV%H_to_Pa ; enddo do K=2,nz do i=is,ie @@ -413,11 +416,11 @@ subroutine smoothed_dRdT_dRdS(h, tv, Kddt, dR_dT, dR_dS, G, GV, j, p_surf, halo) S_EOS(i) = 0.5*(S_f(i,k-1) + S_f(i,k)) enddo call calculate_density_derivs(T_EOS, S_EOS, pres, dR_dT(:,K), dR_dS(:,K), & - is-G%isd+1, ie-is+1, tv%eqn_of_state) + is-G%isd+1, ie-is+1, tv%eqn_of_state, scale=US%kg_m3_to_R) do i=is,ie ; pres(i) = pres(i) + h(i,j,k)*GV%H_to_Pa ; enddo enddo call calculate_density_derivs(T_f(:,nz), S_f(:,nz), pres, dR_dT(:,nz+1), dR_dS(:,nz+1), & - is-G%isd+1, ie-is+1, tv%eqn_of_state) + is-G%isd+1, ie-is+1, tv%eqn_of_state, scale=US%kg_m3_to_R) end subroutine smoothed_dRdT_dRdS diff --git a/src/parameterizations/vertical/MOM_set_diffusivity.F90 b/src/parameterizations/vertical/MOM_set_diffusivity.F90 index 06b7f0f2a5..8b96c87320 100644 --- a/src/parameterizations/vertical/MOM_set_diffusivity.F90 +++ b/src/parameterizations/vertical/MOM_set_diffusivity.F90 @@ -349,7 +349,7 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, & endif call cpu_clock_begin(id_clock_kappaShear) if (CS%Vertex_shear) then - call full_convection(G, GV, h, tv, T_adj, S_adj, fluxes%p_surf, & + call full_convection(G, GV, US, h, tv, T_adj, S_adj, fluxes%p_surf, & (GV%Z_to_H**2)*kappa_dt_fill, halo=1) call calc_kappa_shear_vertex(u, v, h, T_adj, S_adj, tv, fluxes%p_surf, visc%Kd_shear, & @@ -567,7 +567,7 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, & endif if (CS%user_change_diff) then - call user_change_diff(h, tv, G, GV, CS%user_change_diff_CSp, Kd_lay, Kd_int, & + call user_change_diff(h, tv, G, GV, US, CS%user_change_diff_CSp, Kd_lay, Kd_int, & T_f, S_f, dd%Kd_user) endif diff --git a/src/user/user_change_diffusivity.F90 b/src/user/user_change_diffusivity.F90 index 10d04af0c3..86f3e6e99a 100644 --- a/src/user/user_change_diffusivity.F90 +++ b/src/user/user_change_diffusivity.F90 @@ -31,7 +31,7 @@ module user_change_diffusivity !! a diffusivity scaled by Kd_add is added [degLat]. real :: rho_range(4) !< 4 values that define the coordinate potential !! density range over which a diffusivity scaled by - !! Kd_add is added [kg m-3]. + !! Kd_add is added [R ~> kg m-3]. logical :: use_abs_lat !< If true, use the absolute value of latitude when !! setting lat_range. type(diag_ctrl), pointer :: diag => NULL() !< A structure that is used to @@ -44,13 +44,14 @@ module user_change_diffusivity !! main code to alter the diffusivities as needed. The specific example !! implemented here augments the diffusivity for a specified range of latitude !! and coordinate potential density. -subroutine user_change_diff(h, tv, G, GV, CS, Kd_lay, Kd_int, T_f, S_f, Kd_int_add) +subroutine user_change_diff(h, tv, G, GV, US, CS, Kd_lay, Kd_int, T_f, S_f, Kd_int_add) 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 thickness [H ~> m or kg m-2]. type(thermo_var_ptrs), intent(in) :: tv !< A structure containing pointers !! to any available thermodynamic !! fields. Absent fields have NULL ptrs. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(user_change_diff_CS), pointer :: CS !< This module's control structure. real, dimension(SZI_(G),SZJ_(G),SZK_(G)), optional, intent(inout) :: Kd_lay !< The diapycnal diffusivity of !! each layer [Z2 T-1 ~> m2 s-1]. @@ -64,7 +65,7 @@ subroutine user_change_diff(h, tv, G, GV, CS, Kd_lay, Kd_int, T_f, S_f, Kd_int_a !! diffusivity that is being added at !! each interface [Z2 T-1 ~> m2 s-1]. ! Local variables - real :: Rcv(SZI_(G),SZK_(G)) ! The coordinate density in layers [kg m-3]. + real :: Rcv(SZI_(G),SZK_(G)) ! The coordinate density in layers [R ~> kg m-3]. real :: p_ref(SZI_(G)) ! An array of tv%P_Ref pressures. real :: rho_fn ! The density dependence of the input function, 0-1 [nondim]. real :: lat_fn ! The latitude dependence of the input function, 0-1 [nondim]. @@ -106,13 +107,13 @@ subroutine user_change_diff(h, tv, G, GV, CS, Kd_lay, Kd_int, T_f, S_f, Kd_int_a do j=js,je if (present(T_f) .and. present(S_f)) then do k=1,nz - call calculate_density(T_f(:,j,k),S_f(:,j,k),p_ref,Rcv(:,k),& - is,ie-is+1,tv%eqn_of_state) + call calculate_density(T_f(:,j,k), S_f(:,j,k), p_ref, Rcv(:,k),& + is, ie-is+1, tv%eqn_of_state, scale=US%kg_m3_to_R) enddo else do k=1,nz - call calculate_density(tv%T(:,j,k),tv%S(:,j,k),p_ref,Rcv(:,k),& - is,ie-is+1,tv%eqn_of_state) + call calculate_density(tv%T(:,j,k), tv%S(:,j,k), p_ref, Rcv(:,k),& + is, ie-is+1, tv%eqn_of_state, scale=US%kg_m3_to_R) enddo endif @@ -135,7 +136,6 @@ subroutine user_change_diff(h, tv, G, GV, CS, Kd_lay, Kd_int, T_f, S_f, Kd_int_a else lat_fn = val_weights(G%geoLatT(i,j), CS%lat_range) endif - ! rho_int = 0.5*(Rcv(i,k-1) + Rcv(i,k)) rho_fn = val_weights( 0.5*(Rcv(i,k-1) + Rcv(i,k)), CS%rho_range) if (rho_fn * lat_fn > 0.0) then Kd_int(i,j,K) = Kd_int(i,j,K) + CS%Kd_add * rho_fn * lat_fn @@ -163,9 +163,9 @@ end function range_OK !! hit 0 and 1. The values in range must be in ascending order, as can be !! checked by calling range_OK. function val_weights(val, range) result(ans) - real, intent(in) :: val !< Value for which we need an answer. - real, dimension(4), intent(in) :: range !< Range over which the answer is non-zero. - real :: ans !< Return value. + real, intent(in) :: val !< Value for which we need an answer [arbitrary units]. + real, dimension(4), intent(in) :: range !< Range over which the answer is non-zero [arbitrary units]. + real :: ans !< Return value [nondim]. ! Local variables real :: x ! A nondimensional number between 0 and 1. @@ -238,7 +238,7 @@ subroutine user_change_diff_init(Time, G, GV, US, param_file, diag, CS) "is applied. The four values specify the density at "//& "which the extra diffusivity starts to increase from 0, "//& "hits its full value, starts to decrease again, and is "//& - "back to 0.", units="kg m-3", default=-1.0e9) + "back to 0.", units="kg m-3", default=-1.0e9, scale=US%kg_m3_to_R) call get_param(param_file, mdl, "USER_KD_ADD_USE_ABS_LAT", CS%use_abs_lat, & "If true, use the absolute value of latitude when "//& "checking whether a point fits into range of latitudes.", & From 5b76e07682405d165aac9fa7defc21246850f8dc Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 18 Mar 2020 22:20:48 -0400 Subject: [PATCH 111/316] +Converted find_interfaces from a function to a subroutine Converted find_interfaces from a function to a subroutine and revised determine_temperature to rescale arguments and internal variables. Also made the declaration of array sizes consistent with other MOM6 code. All answers are bitwise identical, but there are changes to public interfaces. --- .../MOM_state_initialization.F90 | 9 +- src/tracer/MOM_tracer_Z_init.F90 | 170 ++++++++++-------- 2 files changed, 97 insertions(+), 82 deletions(-) diff --git a/src/initialization/MOM_state_initialization.F90 b/src/initialization/MOM_state_initialization.F90 index 7f420439f3..0965bc2fd8 100644 --- a/src/initialization/MOM_state_initialization.F90 +++ b/src/initialization/MOM_state_initialization.F90 @@ -2009,7 +2009,7 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, G, GV, US, PF, just_read_param logical :: debug = .false. ! manually set this to true for verbose output ! data arrays - real, dimension(:), allocatable :: z_edges_in, z_in + real, dimension(:), allocatable :: z_edges_in, z_in ! Interface heights [Z ~> m] real, dimension(:), allocatable :: Rb ! Interface densities [R ~> kg m-3] real, dimension(:,:,:), allocatable, target :: temp_z, salt_z, mask_z real, dimension(:,:,:), allocatable :: rho_z ! Densities in Z-space [R ~> kg m-3] @@ -2326,9 +2326,8 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, G, GV, US, PF, just_read_param do k=2,nz ; Rb(k) = 0.5*(GV%Rlay(k-1)+GV%Rlay(k)) ; enddo Rb(1) = 0.0 ; Rb(nz+1) = 2.0*GV%Rlay(nz) - GV%Rlay(nz-1) - zi(is:ie,js:je,:) = find_interfaces(rho_z(is:ie,js:je,:), z_in, Rb, G%bathyT(is:ie,js:je), & - nlevs(is:ie,js:je), nkml, nkbl, min_depth, eps_z=eps_z, & - eps_rho=eps_rho) + call find_interfaces(rho_z, z_in, kd, Rb, G%bathyT, zi, G, US, & + nlevs, nkml, nkbl, min_depth, eps_z=eps_z, eps_rho=eps_rho) if (correct_thickness) then call adjustEtaToFitBathymetry(G, GV, US, zi, h) @@ -2399,7 +2398,7 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, G, GV, US, PF, just_read_param if (adjust_temperature .and. .not. useALEremapping) then call determine_temperature(tv%T(is:ie,js:je,:), tv%S(is:ie,js:je,:), & - US%R_to_kg_m3*GV%Rlay(1:nz), tv%p_ref, niter, missing_value, h(is:ie,js:je,:), ks, eos) + GV%Rlay(1:nz), tv%p_ref, niter, missing_value, h(is:ie,js:je,:), ks, US, eos) endif diff --git a/src/tracer/MOM_tracer_Z_init.F90 b/src/tracer/MOM_tracer_Z_init.F90 index 128427c683..aaa670070b 100644 --- a/src/tracer/MOM_tracer_Z_init.F90 +++ b/src/tracer/MOM_tracer_Z_init.F90 @@ -30,7 +30,7 @@ module MOM_tracer_Z_init function tracer_Z_init(tr, h, filename, tr_name, G, US, missing_val, land_val) logical :: tracer_Z_init !< A return code indicating if the initialization has been successful type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & intent(out) :: tr !< The tracer to initialize real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & @@ -612,63 +612,64 @@ function find_limited_slope(val, e, k) result(slope) end function find_limited_slope !> Find interface positions corresponding to density profile -function find_interfaces(rho, zin, Rb, depth, nlevs, nkml, nkbl, hml, debug, eps_z, eps_rho) result(zi) - real, dimension(:,:,:), & - intent(in) :: rho !< potential density in z-space [kg m-3 or R ~> kg m-3] - real, dimension(size(rho,3)), & - intent(in) :: zin !< Input data levels [m or Z ~> m]. - real, dimension(:), intent(in) :: Rb !< target interface densities [kg m-3 or R ~> kg m-3] - real, dimension(size(rho,1),size(rho,2)), & - intent(in) :: depth !< ocean depth [Z ~> m]. - integer, dimension(size(rho,1),size(rho,2)), & - optional, intent(in) :: nlevs !< number of valid points in each column - logical, optional, intent(in) :: debug !< optional debug flag - integer, optional, intent(in) :: nkml !< number of mixed layer pieces - integer, optional, intent(in) :: nkbl !< number of buffer layer pieces - real, optional, intent(in) :: hml !< mixed layer depth [Z ~> m]. - real, optional, intent(in) :: eps_z !< A negligibly small layer thickness [m or Z ~> m]. - real, optional, intent(in) :: eps_rho !< A negligibly small density difference [kg m-3 or R ~> kg m-3]. - real, dimension(size(rho,1),size(rho,2),size(Rb,1)) :: zi !< The returned interface, in the same units az zin. +subroutine find_interfaces(rho, zin, nk_data, Rb, depth, zi, G, US, nlevs, nkml, nkbl, hml, debug, eps_z, eps_rho) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + integer, intent(in) :: nk_data !< The number of levels in the input data + real, dimension(SZI_(G),SZJ_(G),nk_data), & + intent(in) :: rho !< Potential density in z-space [R ~> kg m-3] + real, dimension(nk_data), intent(in) :: zin !< Input data levels [Z ~> m]. + real, dimension(SZK_(G)+1), intent(in) :: Rb !< target interface densities [R ~> kg m-3] + real, dimension(SZI_(G),SZJ_(G)), & + intent(in) :: depth !< ocean depth [Z ~> m]. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1), & + intent(out) :: zi !< The returned interface heights [Z ~> m] + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + integer, dimension(SZI_(G),SZJ_(G)), & + optional, intent(in) :: nlevs !< number of valid points in each column + logical, optional, intent(in) :: debug !< optional debug flag + integer, optional, intent(in) :: nkml !< number of mixed layer pieces + integer, optional, intent(in) :: nkbl !< number of buffer layer pieces + real, optional, intent(in) :: hml !< mixed layer depth [Z ~> m]. + real, optional, intent(in) :: eps_z !< A negligibly small layer thickness [Z ~> m]. + real, optional, intent(in) :: eps_rho !< A negligibly small density difference [R ~> kg m-3]. ! Local variables - real, dimension(size(rho,1),size(rho,3)) :: rho_ ! A slice of densities [R ~> kg m-3] - real, dimension(size(rho,1)) :: depth_ + real, dimension(SZI_(G),nk_data) :: rho_ ! A slice of densities [R ~> kg m-3] logical :: unstable integer :: dir - integer, dimension(size(rho,1),size(Rb,1)) :: ki_ - real, dimension(size(rho,1),size(Rb,1)) :: zi_ - integer, dimension(size(rho,1),size(rho,2)) :: nlevs_data - integer, dimension(size(rho,1)) :: lo, hi + integer, dimension(SZI_(G),SZK_(G)+1) :: ki_ + real, dimension(SZI_(G),SZK_(G)+1) :: zi_ + integer, dimension(SZI_(G),SZJ_(G)) :: nlevs_data + integer, dimension(SZI_(G)) :: lo, hi real :: slope,rsm,drhodz,hml_ - integer :: n,i,j,k,l,nx,ny,nz,nt - integer :: nlay,kk,nkml_,nkbl_ - logical :: debug_ = .false. real :: epsln_Z ! A negligibly thin layer thickness [m or Z ~> m]. real :: epsln_rho ! A negligibly small density change [kg m-3 or R ~> kg m-3]. real, parameter :: zoff=0.999 + integer :: kk,nkml_,nkbl_ + logical :: debug_ = .false. + integer :: i, j, k, m, n, is, ie, js, je, nz - nlay=size(Rb)-1 + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke zi(:,:,:) = 0.0 if (PRESENT(debug)) debug_=debug - nx = size(rho,1); ny=size(rho,2); nz = size(rho,3) - nlevs_data(:,:) = size(rho,3) + nlevs_data(:,:) = nz nkml_ = 0 ; if (PRESENT(nkml)) nkml_ = max(0, nkml) nkbl_ = 0 ; if (PRESENT(nkbl)) nkbl_ = max(0, nkbl) hml_ = 0.0 ; if (PRESENT(hml)) hml_ = hml - epsln_Z = 1.0e-10 ; if (PRESENT(eps_z)) epsln_Z = eps_z - epsln_rho = 1.0e-10 ; if (PRESENT(eps_rho)) epsln_rho = eps_rho + epsln_Z = 1.0e-10*US%m_to_Z ; if (PRESENT(eps_z)) epsln_Z = eps_z + epsln_rho = 1.0e-10*US%kg_m3_to_R ; if (PRESENT(eps_rho)) epsln_rho = eps_rho if (PRESENT(nlevs)) then nlevs_data(:,:) = nlevs(:,:) endif - do j=1,ny + do j=js,je rho_(:,:) = rho(:,j,:) - i_loop: do i=1,nx + i_loop: do i=is,ie if (debug_) then print *,'looking for interfaces, i,j,nlevs= ',i,j,nlevs_data(i,j) print *,'initial density profile= ', rho_(i,:) @@ -712,60 +713,73 @@ function find_interfaces(rho, zin, Rb, depth, nlevs, nkml, nkbl, hml, debug, eps ki_(:,:) = 0 zi_(:,:) = 0.0 - depth_(:) = -1.0*depth(:,j) lo(:) = 1 hi(:) = nlevs_data(:,j) ki_ = bisect_fast(rho_, Rb, lo, hi) ki_(:,:) = max(1, ki_(:,:)-1) - do i=1,nx - do l=2,nlay - slope = (zin(ki_(i,l)+1) - zin(ki_(i,l))) / max(rho_(i,ki_(i,l)+1) - rho_(i,ki_(i,l)),epsln_rho) - zi_(i,l) = -1.0*(zin(ki_(i,l)) + slope*(Rb(l)-rho_(i,ki_(i,l)))) - zi_(i,l) = max(zi_(i,l), depth_(i)) - zi_(i,l) = min(zi_(i,l), -1.0*hml_) + do i=is,ie + do m=2,nz + slope = (zin(ki_(i,m)+1) - zin(ki_(i,m))) / max(rho_(i,ki_(i,m)+1) - rho_(i,ki_(i,m)),epsln_rho) + zi_(i,m) = -1.0*(zin(ki_(i,m)) + slope*(Rb(m)-rho_(i,ki_(i,m)))) + zi_(i,m) = max(zi_(i,m), -depth(i,j)) + zi_(i,m) = min(zi_(i,m), -1.0*hml_) enddo - zi_(i,nlay+1) = depth_(i) - do l=2,nkml_+1 - zi_(i,l) = max(hml_*((1.0-real(l))/real(nkml_)), depth_(i)) + zi_(i,nz+1) = -depth(i,j) + do m=2,nkml_+1 + zi_(i,m) = max(hml_*((1.0-real(m))/real(nkml_)), -depth(i,j)) enddo - do l=nlay,nkml_+2,-1 - if (zi_(i,l) < zi_(i,l+1) + epsln_Z) zi_(i,l) = zi_(i,l+1) + epsln_Z - if (zi_(i,l) > -1.0*hml_) zi_(i,l) = max(-1.0*hml_, depth_(i)) + do m=nz,nkml_+2,-1 + if (zi_(i,m) < zi_(i,m+1) + epsln_Z) zi_(i,m) = zi_(i,m+1) + epsln_Z + if (zi_(i,m) > -1.0*hml_) zi_(i,m) = max(-1.0*hml_, -depth(i,j)) enddo enddo zi(:,j,:) = zi_(:,:) enddo -end function find_interfaces +end subroutine find_interfaces !> This subroutine determines the potential temperature and salinity that !! is consistent with the target density using provided initial guess -subroutine determine_temperature(temp, salt, R, p_ref, niter, land_fill, h, k_start, eos) +subroutine determine_temperature(temp, salt, R_tgt, p_ref, niter, land_fill, h, k_start, US, eos, h_massless) real, dimension(:,:,:), intent(inout) :: temp !< potential temperature [degC] real, dimension(:,:,:), intent(inout) :: salt !< salinity [PSU] - real, dimension(size(temp,3)), intent(in) :: R !< desired potential density [kg m-3]. + real, dimension(size(temp,3)), intent(in) :: R_tgt !< desired potential density [R ~> kg m-3]. real, intent(in) :: p_ref !< reference pressure [Pa]. integer, intent(in) :: niter !< maximum number of iterations integer, intent(in) :: k_start !< starting index (i.e. below the buffer layer) real, intent(in) :: land_fill !< land fill value - real, dimension(:,:,:), intent(in) :: h !< layer thickness, used only to avoid working on massless layers + real, dimension(:,:,:), intent(in) :: h !< layer thickness, used only to avoid working on + !! massless layers [H ~> m or kg m-2] + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(eos_type), pointer :: eos !< seawater equation of state control structure + real, optional, intent(in) :: h_massless !< A threshold below which a layer is + !! determined to be massless [H ~> m or kg m-2] real, parameter :: T_max = 31.0, T_min = -2.0 ! Local variables (All of which need documentation!) - 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 - real(kind=8), dimension(size(temp,1)) :: press + real, dimension(size(temp,1),size(temp,3)) :: & + T, S, dT, dS, & + rho, & ! Layer densities [R ~> kg m-3] + hin, & ! Input layer thicknesses [H ~> m or kg m-2] + drho_dT, & ! Partial derivative of density with temperature [R degC-1 ~> kg m-3 degC-1] + drho_dS ! Partial derivative of density with salinity [R ppt-1 ~> kg m-3 ppt-1] + real, dimension(size(temp,1)) :: press integer :: nx, ny, nz, nt, i, j, k, n, itt real :: dT_dS_gauge ! The relative penalizing of temperature to salinity changes when ! minimizing property changes while correcting density [degC ppt-1]. real :: I_denom ! The inverse of the magnitude squared of the density gradient in - ! T-S space streched with dT_dS_gauge [m6 kg-2 ppt-1] + ! T-S space streched with dT_dS_gauge [ppt2 R-2 ~> ppt2 m6 kg-2] logical :: adjust_salt, old_fit - real, parameter :: S_min = 0.5, S_max=65.0 - real, parameter :: tol_T=1.e-4, tol_S=1.e-4, tol_rho=1.e-4 - real, parameter :: max_t_adj=1.0, max_s_adj = 0.5 - + real :: S_min, S_max + real :: tol_T ! The tolerance for temperature matches [degC] + real :: tol_S ! The tolerance for salinity matches [ppt] + real :: tol_rho ! The tolerance for density matches [R ~> kg m-3] + real :: max_t_adj, max_s_adj + + ! These hard coded parameters need to be set properly. + S_min = 0.5 ; S_max = 65.0 + max_t_adj = 1.0 ; max_s_adj = 0.5 + tol_T=1.e-4 ; tol_S=1.e-4 ; tol_rho = 1.e-4*US%kg_m3_to_R old_fit = .true. ! reproduces siena behavior ! ### The whole determine_temperature subroutine needs to be reexamined, both the algorithms @@ -780,28 +794,29 @@ subroutine determine_temperature(temp, salt, R, p_ref, niter, land_fill, h, k_st do j=1,ny dS(:,:) = 0. ! Needs to be zero everywhere since there is a maxval(abs(dS)) later... - T=temp(:,j,:) - S=salt(:,j,:) - hin=h(:,j,:) - dT=0.0 + T(:,:) = temp(:,j,:) + S(:,:) = salt(:,j,:) + hin(:,:) = h(:,j,:) + dT(:,:) = 0.0 adjust_salt = .true. iter_loop: do itt = 1,niter do k=1, nz - call calculate_density(T(:,k), S(:,k), press, rho(:,k), 1, nx, eos) - call calculate_density_derivs(T(:,k), S(:,k), press, drho_dT(:,k), drho_dS(:,k), 1, nx, eos) + call calculate_density(T(:,k), S(:,k), press, rho(:,k), 1, nx, eos, scale=US%kg_m3_to_R) + call calculate_density_derivs(T(:,k), S(:,k), press, drho_dT(:,k), drho_dS(:,k), 1, nx, & + eos, scale=US%kg_m3_to_R) enddo do k=k_start,nz ; do i=1,nx -! if (abs(rho(i,k)-R(k))>tol .and. hin(i,k)>epsln .and. abs(T(i,k)-land_fill) < epsln) then - if (abs(rho(i,k)-R(k))>tol_rho) then +! if (abs(rho(i,k)-R_tgt(k))>tol_rho .and. hin(i,k)>h_massless .and. abs(T(i,k)-land_fill) < epsln) then + if (abs(rho(i,k)-R_tgt(k))>tol_rho) then if (old_fit) then - dT(i,k) = max(min((R(k)-rho(i,k)) / drho_dT(i,k), max_t_adj), -max_t_adj) + dT(i,k) = max(min((R_tgt(k)-rho(i,k)) / drho_dT(i,k), max_t_adj), -max_t_adj) T(i,k) = max(min(T(i,k)+dT(i,k), T_max), T_min) else dT_dS_gauge = 10.0 ! 10 degC is weighted equivalently to 1 ppt. I_denom = 1.0 / (drho_dS(i,k)**2 + dT_dS_gauge**2*drho_dT(i,k)**2) - dS(i,k) = (R(k)-rho(i,k)) * drho_dS(i,k) * I_denom - dT(i,k) = (R(k)-rho(i,k)) * dT_dS_gauge**2*drho_dT(i,k) * I_denom + dS(i,k) = (R_tgt(k)-rho(i,k)) * drho_dS(i,k) * I_denom + dT(i,k) = (R_tgt(k)-rho(i,k)) * dT_dS_gauge**2*drho_dT(i,k) * I_denom T(i,k) = max(min(T(i,k)+dT(i,k), T_max), T_min) S(i,k) = max(min(S(i,k)+dS(i,k), S_max), S_min) @@ -816,21 +831,22 @@ subroutine determine_temperature(temp, salt, R, p_ref, niter, land_fill, h, k_st if (adjust_salt .and. old_fit) then ; do itt = 1,niter do k=1, nz - call calculate_density(T(:,k),S(:,k),press,rho(:,k),1,nx,eos) - call calculate_density_derivs(T(:,k),S(:,k),press,drho_dT(:,k),drho_dS(:,k),1,nx,eos) + call calculate_density(T(:,k), S(:,k), press, rho(:,k), 1, nx, eos, scale=US%kg_m3_to_R) + call calculate_density_derivs(T(:,k), S(:,k), press, drho_dT(:,k), drho_dS(:,k), 1, nx, & + eos, scale=US%kg_m3_to_R) enddo do k=k_start,nz ; do i=1,nx -! if (abs(rho(i,k)-R(k))>tol .and. hin(i,k)>epsln .and. abs(T(i,k)-land_fill) < epsln ) then - if (abs(rho(i,k)-R(k)) > tol_rho) then - dS(i,k) = max(min((R(k)-rho(i,k)) / drho_dS(i,k), max_s_adj), -max_s_adj) +! if (abs(rho(i,k)-R_tgt(k))>tol_rho .and. hin(i,k)>h_massless .and. abs(T(i,k)-land_fill) < epsln ) then + if (abs(rho(i,k)-R_tgt(k)) > tol_rho) then + dS(i,k) = max(min((R_tgt(k)-rho(i,k)) / drho_dS(i,k), max_s_adj), -max_s_adj) S(i,k) = max(min(S(i,k)+dS(i,k), S_max), S_min) endif enddo ; enddo if (maxval(abs(dS)) < tol_S) exit enddo ; endif - temp(:,j,:)=T(:,:) - salt(:,j,:)=S(:,:) + temp(:,j,:) = T(:,:) + salt(:,j,:) = S(:,:) enddo end subroutine determine_temperature From 7a7488fb0f93ed65efb297fe418e6ebbca0c39e5 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 18 Mar 2020 22:22:00 -0400 Subject: [PATCH 112/316] Removed an unneeded halo update Removed an unneeded halo update in iceberg_forces. All answers are bitwise identical. --- src/ice_shelf/MOM_marine_ice.F90 | 2 -- 1 file changed, 2 deletions(-) diff --git a/src/ice_shelf/MOM_marine_ice.F90 b/src/ice_shelf/MOM_marine_ice.F90 index 533fb5d9ec..4e3ce7401e 100644 --- a/src/ice_shelf/MOM_marine_ice.F90 +++ b/src/ice_shelf/MOM_marine_ice.F90 @@ -96,8 +96,6 @@ subroutine iceberg_forces(G, forces, use_ice_shelf, sfc_state, & 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 From 3be0470b6907c307b3ed941c4316b0288bf88c7f Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 19 Mar 2020 20:02:09 -0400 Subject: [PATCH 113/316] +Rescaled units in area_shelf_h Rescaled the units of the area_shelf_h variable used to initialize frac_shelf_h, and eleminated the unused g_Earth element in the ocean_grid_type. All answers are bitwise identical, but an element was removed from a transparent public type. --- src/core/MOM.F90 | 12 +++--- src/core/MOM_grid.F90 | 1 - .../MOM_state_initialization.F90 | 37 ++++++++++--------- 3 files changed, 24 insertions(+), 26 deletions(-) diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index 49c650fe62..213f81a06e 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -1542,10 +1542,9 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & integer :: i, j, k, is, ie, js, je, isd, ied, jsd, jed, nz integer :: IsdB, IedB, JsdB, JedB real :: dtbt ! The barotropic timestep [s] - real :: Z_diag_int ! minimum interval between calc depth-space diagnosetics [s] real, allocatable, dimension(:,:) :: eta ! free surface height or column mass [H ~> m or kg m-2] - real, allocatable, dimension(:,:) :: area_shelf_h ! area occupied by ice shelf [m2] + real, allocatable, dimension(:,:) :: area_shelf_h ! area occupied by ice shelf [L2 ~> m2] real, dimension(:,:), allocatable, target :: frac_shelf_h ! fraction of total area occupied by ice shelf [nondim] real, dimension(:,:), pointer :: shelf_area => NULL() type(MOM_restart_CS), pointer :: restart_CSp_tmp => NULL() @@ -1975,7 +1974,6 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & call verticalGridInit( param_file, CS%GV, US ) GV => CS%GV -! dG%g_Earth = GV%mks_g_Earth ! Allocate the auxiliary non-symmetric domain for debugging or I/O purposes. if (CS%debug .or. dG%symmetric) & @@ -2172,7 +2170,7 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & else ; G%Domain_aux => G%Domain ; endif ! Copy common variables from the vertical grid to the horizontal grid. ! Consider removing this later? - G%ke = GV%ke ; G%g_Earth = GV%mks_g_Earth + G%ke = GV%ke call MOM_initialize_state(CS%u, CS%v, CS%h, CS%tv, Time, G, GV, US, param_file, & dirs, restart_CSp, CS%ALE_CSp, CS%tracer_Reg, & @@ -2208,7 +2206,7 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & if (CS%debug .or. CS%G%symmetric) then call clone_MOM_domain(CS%G%Domain, CS%G%Domain_aux, symmetric=.false.) else ; CS%G%Domain_aux => CS%G%Domain ;endif - G%ke = GV%ke ; G%g_Earth = GV%mks_g_Earth + G%ke = GV%ke endif ! At this point, all user-modified initialization code has been called. The @@ -2234,13 +2232,13 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & allocate(area_shelf_h(isd:ied,jsd:jed)) allocate(frac_shelf_h(isd:ied,jsd:jed)) - call MOM_read_data(filename, trim(area_varname), area_shelf_h, G%Domain) + call MOM_read_data(filename, trim(area_varname), area_shelf_h, G%Domain, scale=US%m_to_L**2) ! initialize frac_shelf_h with zeros (open water everywhere) frac_shelf_h(:,:) = 0.0 ! compute fractional ice shelf coverage of h do j=jsd,jed ; do i=isd,ied if (G%areaT(i,j) > 0.0) & - frac_shelf_h(i,j) = area_shelf_h(i,j) / (US%L_to_m**2*G%areaT(i,j)) + frac_shelf_h(i,j) = area_shelf_h(i,j) / G%areaT(i,j) enddo ; enddo ! pass to the pointer shelf_area => frac_shelf_h diff --git a/src/core/MOM_grid.F90 b/src/core/MOM_grid.F90 index 10832ffe75..f2c4a7d93b 100644 --- a/src/core/MOM_grid.F90 +++ b/src/core/MOM_grid.F90 @@ -155,7 +155,6 @@ module MOM_grid real ALLOCABLE_, dimension(NIMEM_,NJMEM_) :: & df_dx, & !< Derivative d/dx f (Coriolis parameter) at h-points [T-1 L-1 ~> s-1 m-1]. df_dy !< Derivative d/dy f (Coriolis parameter) at h-points [T-1 L-1 ~> s-1 m-1]. - real :: g_Earth !< The gravitational acceleration [m2 Z-1 s-2 ~> m s-2]. ! These variables are global sums that are useful for 1-d diagnostics and should not be rescaled. real :: areaT_global !< Global sum of h-cell area [m2] diff --git a/src/initialization/MOM_state_initialization.F90 b/src/initialization/MOM_state_initialization.F90 index 0965bc2fd8..afadae1a1b 100644 --- a/src/initialization/MOM_state_initialization.F90 +++ b/src/initialization/MOM_state_initialization.F90 @@ -1009,9 +1009,9 @@ subroutine depress_surface(h, G, GV, US, param_file, tv, just_read_params) !! only read parameters without changing h. ! Local variables real, dimension(SZI_(G),SZJ_(G)) :: & - eta_sfc ! The free surface height that the model should use [m]. + eta_sfc ! The free surface height that the model should use [Z ~> m]. real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1) :: & - eta ! The free surface height that the model should use [m]. + eta ! The free surface height that the model should use [Z ~> m]. real :: dilate ! A ratio by which layers are dilated [nondim]. real :: scale_factor ! A scaling factor for the eta_sfc values that are read ! in, which can be used to change units, for example. @@ -1039,15 +1039,15 @@ subroutine depress_surface(h, G, GV, US, param_file, tv, just_read_params) call log_param(param_file, mdl, "INPUTDIR/SURFACE_HEIGHT_IC_FILE", filename) call get_param(param_file, mdl, "SURFACE_HEIGHT_IC_SCALE", scale_factor, & - "A scaling factor to convert SURFACE_HEIGHT_IC_VAR into "//& - "units of m", units="variable", default=1.0, do_not_log=just_read) + "A scaling factor to convert SURFACE_HEIGHT_IC_VAR into units of m", & + units="variable", default=1.0, scale=US%m_to_Z, do_not_log=just_read) if (just_read) return ! All run-time parameters have been read, so return. call MOM_read_data(filename, eta_srf_var, eta_sfc, G%Domain, scale=scale_factor) ! Convert thicknesses to interface heights. - call find_eta(h, tv, G, GV, US, eta, eta_to_m=1.0) + call find_eta(h, tv, G, GV, US, eta) do j=js,je ; do i=is,ie ; if (G%mask2dT(i,j) > 0.0) then ! if (eta_sfc(i,j) < eta(i,j,nz+1)) then @@ -1398,8 +1398,9 @@ subroutine initialize_velocity_circular(u, v, G, US, param_file, just_read_param !! only read parameters without changing h. ! Local variables character(len=200) :: mdl = "initialize_velocity_circular" - real :: circular_max_u - real :: dpi, psi1, psi2 + real :: circular_max_u ! The amplitude of the zonal flow [L T-1 ~> m s-1] + real :: dpi ! A local variable storing pi = 3.14159265358979... + real :: psi1, psi2 ! Values of the streamfunction at two points [L2 T-1 ~> m2 s-1] logical :: just_read ! If true, just read parameters but set nothing. integer :: i, j, k, is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke @@ -1410,7 +1411,7 @@ subroutine initialize_velocity_circular(u, v, G, US, param_file, just_read_param call get_param(param_file, mdl, "CIRCULAR_MAX_U", circular_max_u, & "The amplitude of zonal flow from which to scale the "// & "circular stream function [m s-1].", & - units="m s-1", default=0., scale=US%L_T_to_m_s, do_not_log=just_read) + units="m s-1", default=0., scale=US%m_s_to_L_T, do_not_log=just_read) if (just_read) return ! All run-time parameters have been read, so return. @@ -1419,29 +1420,29 @@ subroutine initialize_velocity_circular(u, v, G, US, param_file, just_read_param do k=1,nz ; do j=js,je ; do I=Isq,Ieq psi1 = my_psi(I,j) psi2 = my_psi(I,j-1) - u(I,j,k) = (psi1-psi2) / (G%US%L_to_m*G%dy_Cu(I,j)) ! *(circular_max_u*G%len_lon/(2.0*dpi)) + u(I,j,k) = (psi1 - psi2) / G%dy_Cu(I,j) ! *(circular_max_u*G%len_lon/(2.0*dpi)) enddo ; enddo ; enddo do k=1,nz ; do J=Jsq,Jeq ; do i=is,ie psi1 = my_psi(i,J) psi2 = my_psi(i-1,J) - v(i,J,k) = (psi2-psi1) / (G%US%L_to_m*G%dx_Cv(i,J)) ! *(circular_max_u*G%len_lon/(2.0*dpi)) + v(i,J,k) = (psi2 - psi1) / G%dx_Cv(i,J) ! *(circular_max_u*G%len_lon/(2.0*dpi)) enddo ; enddo ; enddo contains - !> Returns the value of a circular stream function at (ig,jg) + !> Returns the value of a circular stream function at (ig,jg) in [L2 T-1 ~> m2 s-1] real function my_psi(ig,jg) integer :: ig !< Global i-index integer :: jg !< Global j-index ! Local variables - real :: x, y, r + real :: x, y, r ! [nondim] x = 2.0*(G%geoLonBu(ig,jg)-G%west_lon) / G%len_lon - 1.0 ! -1 m]. - real, dimension(:,:), allocatable :: area_shelf_h - real, dimension(:,:), allocatable, target :: frac_shelf_h + real, dimension(:,:), allocatable :: area_shelf_h ! Shelf-covered area per grid cell [L2 ~> m2] + real, dimension(:,:), allocatable, target :: frac_shelf_h ! Fractional shelf area per grid cell [nondim] real, dimension(:,:,:), allocatable, target :: tmpT1dIn, tmpS1dIn real, dimension(:,:,:), allocatable :: tmp_mask_in real, dimension(:,:,:), allocatable :: h1 ! Thicknesses [H ~> m or kg m-2]. @@ -2060,7 +2061,7 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, G, GV, US, PF, just_read_param ! call mpp_get_compute_domain(G%domain%mpp_domain,isc,iec,jsc,jec) - reentrant_x = .false. ; call get_param(PF, mdl, "REENTRANT_X", reentrant_x,default=.true.) + reentrant_x = .false. ; call get_param(PF, mdl, "REENTRANT_X", reentrant_x, default=.true.) tripolar_n = .false. ; call get_param(PF, mdl, "TRIPOLAR_N", tripolar_n, default=.false.) call get_param(PF, mdl, "MINIMUM_DEPTH", min_depth, default=0.0, scale=US%m_to_Z) @@ -2204,14 +2205,14 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, G, GV, US, PF, just_read_param if (.not.file_exists(shelf_file, G%Domain)) call MOM_error(FATAL, & "MOM_temp_salt_initialize_from_Z: Unable to open shelf file "//trim(shelf_file)) - call MOM_read_data(shelf_file, trim(area_varname), area_shelf_h, G%Domain) + call MOM_read_data(shelf_file, trim(area_varname), area_shelf_h, G%Domain, scale=US%m_to_L**2) ! Initialize frac_shelf_h with zeros (open water everywhere) frac_shelf_h(:,:) = 0.0 ! Compute fractional ice shelf coverage of h do j=jsd,jed ; do i=isd,ied if (G%areaT(i,j) > 0.0) & - frac_shelf_h(i,j) = area_shelf_h(i,j) / (US%L_to_m**2*G%areaT(i,j)) + frac_shelf_h(i,j) = area_shelf_h(i,j) / G%areaT(i,j) enddo ; enddo ! Pass to the pointer for use as an argument to regridding_main shelf_area => frac_shelf_h From a99e4449006ecf16eba5eafeab07b547d7884e78 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 19 Mar 2020 20:05:15 -0400 Subject: [PATCH 114/316] Corrected more documented units in comments Corrected additional documented units in comments, corrected spelling errors in comments and removed unused variables. Also noted some probable dimensional consistency errors in MOM_open_boundary.F90. All answers are bitwise identical. --- src/ALE/MOM_regridding.F90 | 4 ++-- src/core/MOM_barotropic.F90 | 2 -- src/core/MOM_forcing_type.F90 | 2 +- src/core/MOM_interface_heights.F90 | 4 ++-- src/core/MOM_open_boundary.F90 | 13 ++++++++----- .../lateral/MOM_internal_tides.F90 | 2 +- .../lateral/MOM_thickness_diffuse.F90 | 2 -- .../vertical/MOM_diapyc_energy_req.F90 | 2 +- .../vertical/MOM_energetic_PBL.F90 | 2 +- src/parameterizations/vertical/MOM_geothermal.F90 | 4 ++-- .../vertical/MOM_set_diffusivity.F90 | 4 ++-- src/parameterizations/vertical/MOM_tidal_mixing.F90 | 12 ++++++------ src/user/Idealized_Hurricane.F90 | 2 +- src/user/baroclinic_zone_initialization.F90 | 6 +++--- 14 files changed, 30 insertions(+), 31 deletions(-) diff --git a/src/ALE/MOM_regridding.F90 b/src/ALE/MOM_regridding.F90 index b1897aeb2e..f73e6e304f 100644 --- a/src/ALE/MOM_regridding.F90 +++ b/src/ALE/MOM_regridding.F90 @@ -560,7 +560,7 @@ subroutine initialize_regridding(CS, GV, US, max_depth, param_file, mdl, coord_m call get_param(param_file, mdl, "HALOCLINE_FILTER_LENGTH", filt_len, & "A length scale over which to smooth the temperature and "//& "salinity before identifying erroneously unstable haloclines.", & - units="m", default=2.0) + units="m", default=2.0, scale=GV%m_to_H) call get_param(param_file, mdl, "HALOCLINE_STRAT_TOL", strat_tol, & "A tolerance for the ratio of the stratification of the "//& "apparent coordinate stratification to the actual value "//& @@ -2247,7 +2247,7 @@ subroutine set_regrid_params( CS, boundary_extrapolation, min_thickness, old_gri !! 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] + !! spuriously unstable water mass profiles [H ~> m or kg m-2] 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 diff --git a/src/core/MOM_barotropic.F90 b/src/core/MOM_barotropic.F90 index 00f6f3cd3e..5998f08c16 100644 --- a/src/core/MOM_barotropic.F90 +++ b/src/core/MOM_barotropic.F90 @@ -2540,9 +2540,7 @@ subroutine apply_velocity_OBCs(OBC, ubt, vbt, uhbt, vhbt, ubt_trans, vbt_trans, integer :: i, j, is, ie, js, je real, dimension(SZIB_(G),SZJB_(G)) :: grad real, parameter :: eps = 1.0e-20 - real :: rx_max, ry_max ! coefficients for radiation is = G%isc-halo ; ie = G%iec+halo ; js = G%jsc-halo ; je = G%jec+halo - rx_max = OBC%rx_max ; ry_max = OBC%rx_max if (BT_OBC%apply_u_OBCs) then do j=js,je ; do I=is-1,ie ; if (OBC%segnum_u(I,j) /= OBC_NONE) then diff --git a/src/core/MOM_forcing_type.F90 b/src/core/MOM_forcing_type.F90 index 98d55d2146..167ae0581d 100644 --- a/src/core/MOM_forcing_type.F90 +++ b/src/core/MOM_forcing_type.F90 @@ -2252,7 +2252,7 @@ subroutine forcing_diagnostics(fluxes, sfc_state, G, US, time_end, diag, handles real, dimension(SZI_(G),SZJ_(G)) :: res real :: total_transport ! for diagnosing integrated boundary transport real :: ave_flux ! for diagnosing averaged boundary flux - real :: C_p ! seawater heat capacity (J/(deg K * kg)) + real :: C_p ! seawater heat capacity [J degC-1 kg-1] real :: RZ_T_conversion ! A combination of scaling factors for mass fluxes [kg T m-2 s-1 R-1 Z-1 ~> 1] real :: I_dt ! inverse time step [s-1] real :: ppt2mks ! conversion between ppt and mks diff --git a/src/core/MOM_interface_heights.F90 b/src/core/MOM_interface_heights.F90 index 6db05423da..8dbacf6798 100644 --- a/src/core/MOM_interface_heights.F90 +++ b/src/core/MOM_interface_heights.F90 @@ -47,11 +47,11 @@ subroutine find_eta_3d(h, tv, G, GV, US, eta, eta_bt, halo_size, eta_to_m) !! the units of eta to m; by default this is US%Z_to_m. ! Local variables - real :: p(SZI_(G),SZJ_(G),SZK_(G)+1) + real :: p(SZI_(G),SZJ_(G),SZK_(G)+1) ! Hydrostatic pressure at each interface [Pa] real :: dz_geo(SZI_(G),SZJ_(G),SZK_(G)) ! The change in geopotential height ! across a layer [m2 s-2]. real :: dilate(SZI_(G)) ! non-dimensional dilation factor - real :: htot(SZI_(G)) ! total thickness H + real :: htot(SZI_(G)) ! total thickness [H ~> m or kg m-2] real :: I_gEarth real :: Z_to_eta, H_to_eta, H_to_rho_eta ! Unit conversion factors with obvious names. integer i, j, k, isv, iev, jsv, jev, nz, halo diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index 5223cbf703..927548665e 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -74,7 +74,8 @@ module MOM_open_boundary real, pointer, dimension(:,:,:) :: buffer_src=>NULL() !< buffer for segment data located at cell faces !! and on the original vertical grid integer :: nk_src !< Number of vertical levels in the source data - real, dimension(:,:,:), pointer :: dz_src=>NULL() !< vertical grid cell spacing of the incoming segment data [m] + real, dimension(:,:,:), pointer :: dz_src=>NULL() !< vertical grid cell spacing of the incoming segment + !! data, set in [Z ~> m] then scaled to [H ~> m or kg m-2] real, dimension(:,:,:), pointer :: buffer_dst=>NULL() !< buffer src data remapped to the target vertical grid real, dimension(:,:), pointer :: bt_vel=>NULL() !< barotropic velocity [L T-1 ~> m s-1] real :: value !< constant value if fid is equal to -1 @@ -260,6 +261,7 @@ module MOM_open_boundary real :: rx_max !< The maximum magnitude of the baroclinic radiation !! velocity (or speed of characteristics) [m s-1]. The !! default value is 10 m s-1. + !### The description above seems inconsistent with the code, and the units should be [nondim]. logical :: OBC_pe !< Is there an open boundary on this tile? type(remapping_CS), pointer :: remap_CS !< ALE remapping control structure for segments only type(OBC_registry_type), pointer :: OBC_Reg => NULL() !< Registry type for boundaries @@ -478,11 +480,13 @@ subroutine open_boundary_config(G, US, param_file, OBC) call initialize_segment_data(G, OBC, param_file) if (open_boundary_query(OBC, apply_open_OBC=.true.)) then + !### I think that OBC%rx_max as used is actually nondimensional, with effective + ! units of grid points per time step. call get_param(param_file, mdl, "OBC_RADIATION_MAX", OBC%rx_max, & "The maximum magnitude of the baroclinic radiation "//& "velocity (or speed of characteristics). This is only "//& "used if one of the open boundary segments is using Orlanski.", & - units="m s-1", default=10.0) + units="m s-1", default=10.0) !### Should the units here be "nondim"? call get_param(param_file, mdl, "OBC_RAD_VEL_WT", OBC%gamma_uv, & "The relative weighting for the baroclinic radiation "//& "velocities (or speed of characteristics) at the new "//& @@ -3421,7 +3425,7 @@ subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(ocean_OBC_type), pointer :: OBC !< Open boundary structure type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamics structure - real, dimension(SZI_(G),SZJ_(G), SZK_(G)), intent(inout) :: h !< Thickness [m] + real, dimension(SZI_(G),SZJ_(G), SZK_(G)), intent(inout) :: h !< Thickness [H ~> m or kg m-2] type(time_type), intent(in) :: Time !< Model time ! Local variables integer :: i, j, k, is, ie, js, je, isd, ied, jsd, jed @@ -3429,8 +3433,7 @@ subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) character(len=40) :: mdl = "set_OBC_segment_data" ! This subroutine's name. character(len=200) :: filename, OBC_file, inputdir ! Strings for file/path type(OBC_segment_type), pointer :: segment => NULL() - integer, dimension(4) :: siz,siz2 - real :: sumh ! column sum of thicknesses [m] + integer, dimension(4) :: siz integer :: ni_seg, nj_seg ! number of src gridpoints along the segments integer :: i2, j2 ! indices for referencing local domain array integer :: is_obc, ie_obc, js_obc, je_obc ! segment indices within local domain diff --git a/src/parameterizations/lateral/MOM_internal_tides.F90 b/src/parameterizations/lateral/MOM_internal_tides.F90 index 0d76b10c03..dda892dc3e 100644 --- a/src/parameterizations/lateral/MOM_internal_tides.F90 +++ b/src/parameterizations/lateral/MOM_internal_tides.F90 @@ -441,7 +441,7 @@ subroutine propagate_int_tide(h, tv, cn, TKE_itidal_input, vel_btTide, Nb, dt, & ! Dissipate energy if Fr>1; done here with an arbitrary time scale if (Fr2_max > 1.0) then En_initial = sum(CS%En(i,j,:,fr,m)) ! for debugging - ! Calculate effective decay rate [s-1] if breaking occurs over a time step + ! Calculate effective decay rate [T-1 ~> s-1] if breaking occurs over a time step loss_rate = (1.0 - Fr2_max) / (Fr2_max * dt) do a=1,CS%nAngle ! Determine effective dissipation rate (Wm-2) diff --git a/src/parameterizations/lateral/MOM_thickness_diffuse.F90 b/src/parameterizations/lateral/MOM_thickness_diffuse.F90 index ed3fc7aa4c..98b56c1cc8 100644 --- a/src/parameterizations/lateral/MOM_thickness_diffuse.F90 +++ b/src/parameterizations/lateral/MOM_thickness_diffuse.F90 @@ -1400,7 +1400,6 @@ subroutine add_detangling_Kh(h, e, Kh_u, Kh_v, KH_u_CFL, KH_v_CFL, tv, dt, G, GV ! normalized by the arithmetic mean thickness. real :: Kh_scale ! A ratio by which Kh_u_CFL is scaled for maximally jagged ! layers [nondim]. -! real :: Kh_det ! The detangling diffusivity [m2 s-1]. real :: h_neglect ! A thickness that is so small it is usually lost ! in roundoff and can be neglected [H ~> m or kg m-2]. @@ -1422,7 +1421,6 @@ subroutine add_detangling_Kh(h, e, Kh_u, Kh_v, KH_u_CFL, KH_v_CFL, tv, dt, G, GV ! the damping timescale [T-1 ~> s-1]. real :: Fn_R ! A function of Rsl, such that Rsl < Fn_R < 1. real :: denom, I_denom ! A denominator and its inverse, various units. - ! real :: Kh_min ! A local floor on the diffusivity [m2 s-1]. real :: Kh_max ! A local ceiling on the diffusivity [L2 T-1 ~> m2 s-1]. real :: wt1, wt2 ! Nondimensional weights. ! Variables used only in testing code. diff --git a/src/parameterizations/vertical/MOM_diapyc_energy_req.F90 b/src/parameterizations/vertical/MOM_diapyc_energy_req.F90 index 32b6feeded..fd8d19aa61 100644 --- a/src/parameterizations/vertical/MOM_diapyc_energy_req.F90 +++ b/src/parameterizations/vertical/MOM_diapyc_energy_req.F90 @@ -1193,7 +1193,7 @@ subroutine find_PE_chg_orig(Kddt_h, h_k, b_den_1, dTe_term, dSe_term, & real :: b1Kd ! Temporary array [nondim] real :: ColHt_chg ! The change in column thickness [Z ~> m]. real :: dColHt_max ! The change in column thickness for infinite diffusivity [Z ~> m]. - real :: dColHt_dKd ! The partial derivative of column thickness with diffusivity [s Z-1 ~> s m-1]. + real :: dColHt_dKd ! The partial derivative of column thickness with Kddt_h [Z H-1 ~> 1 or m3 kg-1]. real :: dT_k, dT_km1 ! Temporary arrays [degC]. real :: dS_k, dS_km1 ! Temporary arrays [ppt]. real :: I_Kr_denom ! Temporary arrays [H-2 ~> m-2 or m4 kg-2]. diff --git a/src/parameterizations/vertical/MOM_energetic_PBL.F90 b/src/parameterizations/vertical/MOM_energetic_PBL.F90 index 483934e38f..7ba477466e 100644 --- a/src/parameterizations/vertical/MOM_energetic_PBL.F90 +++ b/src/parameterizations/vertical/MOM_energetic_PBL.F90 @@ -1664,7 +1664,7 @@ subroutine find_PE_chg_orig(Kddt_h, h_k, b_den_1, dTe_term, dSe_term, & real :: b1Kd ! Temporary array [nondim] real :: ColHt_chg ! The change in column thickness [Z ~> m]. real :: dColHt_max ! The change in column thickness for infinite diffusivity [Z ~> m]. - real :: dColHt_dKd ! The partial derivative of column thickness with diffusivity [s Z-1 ~> s m-1]. + real :: dColHt_dKd ! The partial derivative of column thickness with Kddt_h [Z H-1 ~> 1 or m3 kg-2]. real :: dT_k, dT_km1 ! Temporary arrays [degC]. real :: dS_k, dS_km1 ! Temporary arrays [ppt]. real :: I_Kr_denom ! Temporary array [H-2 ~> m-2 or m4 kg-2] diff --git a/src/parameterizations/vertical/MOM_geothermal.F90 b/src/parameterizations/vertical/MOM_geothermal.F90 index 2e2c87fcd5..e26e126db8 100644 --- a/src/parameterizations/vertical/MOM_geothermal.F90 +++ b/src/parameterizations/vertical/MOM_geothermal.F90 @@ -111,11 +111,11 @@ subroutine geothermal(h, tv, dt, ea, eb, G, GV, US, CS, halo) ! for diagnostics [degC] real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: h_old ! Thickness of each layer ! before any heat is added, - ! for diagnostics [m or kg m-2] + ! for diagnostics [H ~> m or kg m-2] real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: work_3d ! Scratch variable used to ! calculate change in heat ! due to geothermal - real :: Idt ! inverse of the timestep [s-1] + real :: Idt ! inverse of the timestep [T-1 ~> s-1] logical :: do_i(SZI_(G)) logical :: compute_h_old, compute_T_old diff --git a/src/parameterizations/vertical/MOM_set_diffusivity.F90 b/src/parameterizations/vertical/MOM_set_diffusivity.F90 index 8b96c87320..3229a7bf80 100644 --- a/src/parameterizations/vertical/MOM_set_diffusivity.F90 +++ b/src/parameterizations/vertical/MOM_set_diffusivity.F90 @@ -677,7 +677,7 @@ subroutine find_TKE_to_Kd(h, tv, dRho_int, N2_lay, j, dt, G, GV, US, CS, & real :: I_Rho0 ! inverse of Boussinesq reference density [R-1 ~> m3 kg-1] real :: I_dt ! 1/dt [T-1 ~> s-1] real :: H_neglect ! negligibly small thickness [H ~> m or kg m-2] - real :: hN2pO2 ! h (N^2 + Omega^2), in [m3 T-2 Z-2 ~> m s-2]. + real :: hN2pO2 ! h (N^2 + Omega^2), in [Z T-2 ~> m s-2]. logical :: do_i(SZI_(G)) integer :: i, k, is, ie, nz, i_rem, kmb, kb_min @@ -1118,7 +1118,7 @@ subroutine add_drag_diffusivity(h, u, v, tv, fluxes, visc, j, TKE_to_Kd, & !! usually (~Rho_0 / (G_Earth * dRho_lay)) !! [Z2 T-1 / Z3 T-3 = T2 Z-1 ~> s2 m-1] real, dimension(SZI_(G),SZK_(G)), intent(in) :: maxTKE !< The energy required to for a layer to entrain - !! to its maximum-realizable thickness [m3 T-3 ~> m3 s-3] + !! to its maximum-realizable thickness [Z3 T-3 ~> m3 s-3] integer, dimension(SZI_(G)), intent(in) :: kb !< Index of lightest layer denser than the buffer !! layer, or -1 without a bulk mixed layer type(set_diffusivity_CS), pointer :: CS !< Diffusivity control structure diff --git a/src/parameterizations/vertical/MOM_tidal_mixing.F90 b/src/parameterizations/vertical/MOM_tidal_mixing.F90 index 510a20f552..9b5f00be61 100644 --- a/src/parameterizations/vertical/MOM_tidal_mixing.F90 +++ b/src/parameterizations/vertical/MOM_tidal_mixing.F90 @@ -48,7 +48,7 @@ module MOM_tidal_mixing Kd_Niku_work => NULL(),& !< layer integrated work by lee-wave driven mixing [R Z3 T-3 ~> W m-2] Kd_Itidal_Work => NULL(),& !< layer integrated work by int tide driven mixing [R Z3 T-3 ~> W m-2] Kd_Lowmode_Work => NULL(),& !< layer integrated work by low mode driven mixing [R Z3 T-3 ~> W m-2] - N2_int => NULL(),& !< Bouyancy frequency squared at interfaces [s-2] + N2_int => NULL(),& !< Bouyancy frequency squared at interfaces [T-2 ~> s-2] vert_dep_3d => NULL(),& !< The 3-d mixing energy deposition [W m-3] Schmittner_coeff_3d => NULL() !< The coefficient in the Schmittner et al mixing scheme, in UNITS? real, pointer, dimension(:,:,:) :: tidal_qe_md => NULL() !< Input tidal energy dissipated locally, @@ -61,8 +61,8 @@ module MOM_tidal_mixing TKE_itidal_used => NULL(),& !< internal tide TKE input at ocean bottom [R Z3 T-3 ~> W m-2] N2_bot => NULL(),& !< bottom squared buoyancy frequency [T-2 ~> s-2] N2_meanz => NULL(),& !< vertically averaged buoyancy frequency [T-2 ~> s-2] - Polzin_decay_scale_scaled => NULL(),& !< vertical scale of decay for tidal dissipation - Polzin_decay_scale => NULL(),& !< vertical decay scale for tidal diss with Polzin [m] + Polzin_decay_scale_scaled => NULL(),& !< vertical scale of decay for tidal dissipation [Z ~> m] + Polzin_decay_scale => NULL(),& !< vertical decay scale for tidal diss with Polzin [Z ~> m] Simmons_coeff_2d => NULL() !< The Simmons et al mixing coefficient end type @@ -153,8 +153,8 @@ module MOM_tidal_mixing !! by the bottom stratfication [R Z3 T-2 ~> J m-2]. real, pointer, dimension(:,:) :: Nb => NULL() !< The near bottom buoyancy frequency [T-1 ~> s-1]. real, pointer, dimension(:,:) :: mask_itidal => NULL() !< A mask of where internal tide energy is input - real, pointer, dimension(:,:) :: h2 => NULL() !< Squared bottom depth variance [m2]. - real, pointer, dimension(:,:) :: tideamp => NULL() !< RMS tidal amplitude [m s-1] + real, pointer, dimension(:,:) :: h2 => NULL() !< Squared bottom depth variance [Z2 ~> m2]. + real, pointer, dimension(:,:) :: tideamp => NULL() !< RMS tidal amplitude [Z T-1 ~> m s-1] real, allocatable, dimension(:) :: h_src !< tidal constituent input layer thickness [m] real, allocatable, dimension(:,:) :: tidal_qe_2d !< Tidal energy input times the local dissipation !! fraction, q*E(x,y), with the CVMix implementation @@ -590,7 +590,7 @@ logical function tidal_mixing_init(Time, G, GV, US, param_file, diag, CS) if (CS%use_CVMix_tidal) then CS%id_N2_int = register_diag_field('ocean_model','N2_int',diag%axesTi,Time, & - 'Bouyancy frequency squared, at interfaces', 's-2') + 'Bouyancy frequency squared, at interfaces', 's-2') !###, conversion=US%s_to_T**2) !> TODO: add units CS%id_Simmons_coeff = register_diag_field('ocean_model','Simmons_coeff',diag%axesT1,Time, & 'time-invariant portion of the tidal mixing coefficient using the Simmons', '') diff --git a/src/user/Idealized_Hurricane.F90 b/src/user/Idealized_Hurricane.F90 index ff2a533d99..38ba0ab460 100644 --- a/src/user/Idealized_Hurricane.F90 +++ b/src/user/Idealized_Hurricane.F90 @@ -652,7 +652,7 @@ subroutine SCM_idealized_hurricane_wind_forcing(state, forces, day, G, US, CS) endif forces%tauy(I,j) = CS%rho_a * US%L_to_Z * G%mask2dCv(I,j) * Cd*dU10*dV enddo ; enddo - ! Set the surface friction velocity [m s-1]. ustar is always positive. + ! Set the surface friction velocity [Z T-1 ~> m s-1]. ustar is always positive. do j=js,je ; do i=is,ie ! This expression can be changed if desired, but need not be. forces%ustar(i,j) = G%mask2dT(i,j) * sqrt(US%L_to_Z * (CS%gustiness/CS%Rho0 + & diff --git a/src/user/baroclinic_zone_initialization.F90 b/src/user/baroclinic_zone_initialization.F90 index 8f3ad67ca9..b1977b3fdd 100644 --- a/src/user/baroclinic_zone_initialization.F90 +++ b/src/user/baroclinic_zone_initialization.F90 @@ -40,8 +40,8 @@ subroutine bcz_params(G, GV, US, param_file, S_ref, dSdz, delta_S, dSdx, T_ref, real, intent(out) :: T_ref !< Reference temperature [degC] real, intent(out) :: dTdz !< Temperature stratification [degC Z-1 ~> degC m-1] real, intent(out) :: delta_T !< Temperature difference across baroclinic zone [degC] - real, intent(out) :: dTdx !< Linear temperature gradient [degC m-1] - real, intent(out) :: L_zone !< Width of baroclinic zone [m] + real, intent(out) :: dTdx !< Linear temperature gradient in [degC G%x_axis_units-1] + real, intent(out) :: L_zone !< Width of baroclinic zone in [G%x_axis_units] logical, optional, intent(in) :: just_read_params !< If present and true, this call will !! only read parameters without changing h. @@ -90,7 +90,7 @@ subroutine baroclinic_zone_init_temperature_salinity(T, S, h, G, GV, US, param_f integer :: i, j, k, is, ie, js, je, nz real :: T_ref, dTdz, dTdx, delta_T ! Parameters describing temperature distribution real :: S_ref, dSdz, dSdx, delta_S ! Parameters describing salinity distribution - real :: L_zone ! Width of baroclinic zone + real :: L_zone ! Width of baroclinic zone in [G%axis_units] real :: zc, zi ! Depths in depth units [Z ~> m] real :: x, xd, xs, y, yd, fn real :: PI ! 3.1415926... calculated as 4*atan(1) From c46d97c8f4ec952552c6fec8c57e4c7d43550577 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sat, 21 Mar 2020 10:36:50 -0400 Subject: [PATCH 115/316] +Rescaled ISS%area_shelf_h to [L2] Rescaled the dimensions of ISS%area_shelf_h to [L2], and renamed float_frac to ground_frac to better reflect the meaning of this variable. All answers are bitwise identical, but there are changes to the units of some arguments to public interfaces. --- src/ice_shelf/MOM_ice_shelf.F90 | 53 +++++++----- src/ice_shelf/MOM_ice_shelf_dynamics.F90 | 99 ++++++++++------------ src/ice_shelf/MOM_ice_shelf_initialize.F90 | 25 +++--- src/ice_shelf/MOM_ice_shelf_state.F90 | 2 +- src/ice_shelf/user_shelf_init.F90 | 10 +-- 5 files changed, 96 insertions(+), 93 deletions(-) diff --git a/src/ice_shelf/MOM_ice_shelf.F90 b/src/ice_shelf/MOM_ice_shelf.F90 index a0f54efb2d..e262d35c74 100644 --- a/src/ice_shelf/MOM_ice_shelf.F90 +++ b/src/ice_shelf/MOM_ice_shelf.F90 @@ -637,7 +637,7 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) ! mass flux [kg s-1], part of ISOMIP diags. mass_flux(:,:) = 0.0 - mass_flux(:,:) = ISS%water_flux(:,:) * ISS%area_shelf_h(:,:) + mass_flux(:,:) = ISS%water_flux(:,:) * US%L_to_m**2*ISS%area_shelf_h(:,:) if (CS%active_shelf_dynamics .or. CS%override_shelf_movement) then call cpu_clock_begin(id_clock_pass) @@ -786,21 +786,21 @@ subroutine add_shelf_forces(G, US, CS, forces, do_shelf_area) 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)) / & - (US%L_to_m**2*G%areaT(i,j) + US%L_to_m**2*G%areaT(i+1,j))) + 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)) / & - (US%L_to_m**2*G%areaT(i,j) + US%L_to_m**2*G%areaT(i,j+1))) + 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 !### Consider working over a smaller array range. do j=jsd,jed ; do i=isd,ied - press_ice = (ISS%area_shelf_h(i,j) * US%m_to_L**2*G%IareaT(i,j)) * (CS%g_Earth * ISS%mass_shelf(i,j)) + 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 @@ -852,7 +852,7 @@ subroutine add_shelf_pressure(G, US, CS, fluxes) call MOM_error(FATAL,"add_shelf_pressure: Incompatible ocean and ice shelf grids.") do j=js,je ; do i=is,ie - press_ice = (CS%ISS%area_shelf_h(i,j) * US%m_to_L**2*G%IareaT(i,j)) * (CS%g_Earth * CS%ISS%mass_shelf(i,j)) + 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 @@ -882,7 +882,7 @@ subroutine add_shelf_flux(G, US, CS, state, fluxes) real :: taux2, tauy2 !< The squared surface stresses [Pa]. real :: press_ice !< The pressure of the ice shelf per unit area of ocean (not ice) [Pa]. real :: asu1, asu2 !< Ocean areas covered by ice shelves at neighboring u- - real :: asv1, asv2 !< and v-points [m2]. + real :: asv1, asv2 !< and v-points [L2 ~> m2]. real :: fraz !< refreezing rate [kg m-2 s-1] real :: mean_melt_flux !< spatial mean melt flux [kg s-1] or [kg m-2 s-1] at various points in the code. real :: sponge_area !< total area of sponge region [m2] @@ -894,7 +894,7 @@ subroutine add_shelf_flux(G, US, CS, state, fluxes) !! at at previous time (Time-dt) 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 [m2] + real, dimension(SZDI_(G),SZDJ_(G)) :: last_area_shelf_h !< Ice shelf area [L2 ~> m2] !! at at previous time (Time-dt) type(ice_shelf_state), pointer :: ISS => NULL() !< A structure with elements that describe !! the ice-shelf state @@ -951,7 +951,7 @@ subroutine add_shelf_flux(G, US, CS, state, fluxes) 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) * US%m_to_L**2*G%IareaT(i,j) + fluxes%frac_shelf_h(i,j) = ISS%area_shelf_h(i,j) * G%IareaT(i,j) enddo ; enddo endif @@ -998,7 +998,7 @@ subroutine add_shelf_flux(G, US, CS, state, fluxes) do j=js,je ; do i=is,ie 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) + mean_melt_flux = mean_melt_flux + (ISS%water_flux(i,j)) * US%L_to_m**2*ISS%area_shelf_h(i,j) !### 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 @@ -1031,8 +1031,8 @@ subroutine add_shelf_flux(G, US, CS, state, fluxes) ! 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)) + shelf_mass0 = shelf_mass0 + (last_mass_shelf(i,j) * US%L_to_m**2*ISS%area_shelf_h(i,j)) + shelf_mass1 = shelf_mass1 + (ISS%mass_shelf(i,j) * US%L_to_m**2*ISS%area_shelf_h(i,j)) endif enddo ; enddo call sum_across_PEs(shelf_mass0); call sum_across_PEs(shelf_mass1) @@ -1099,7 +1099,9 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl type(directories) :: dirs type(dyn_horgrid_type), pointer :: dG => NULL() real :: Z_rescale ! A rescaling factor for heights from the representation in - ! a reastart fole to the internal representation in this run. + ! a restart file to the internal representation in this run. + real :: L_rescale ! A rescaling factor for horizontal lengths from the representation in + ! a restart file to the internal representation in this run. real :: cdrag, drag_bg_vel logical :: new_sim, save_IC, var_force !This include declares and sets the variable "version". @@ -1328,7 +1330,7 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl call get_param(param_file, mdl, "INPUTDIR", inputdir, default=".") inputdir = slasher(inputdir) TideAmp_file = trim(inputdir) // trim(TideAmp_file) - call MOM_read_data(TideAmp_file,'tideamp',CS%utide,G%domain,timelevel=1) + call MOM_read_data(TideAmp_file, 'tideamp', CS%utide, G%domain, timelevel=1) else call get_param(param_file, mdl, "UTIDE", utide, & "The constant tidal amplitude used with INT_TIDE_DISSIPATION.", & @@ -1421,6 +1423,8 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl "ice sheet/shelf thickness", "m") call register_restart_field(US%m_to_Z_restart, "m_to_Z", .false., CS%restart_CSp, & "Height unit conversion factor", "Z meter-1") + call register_restart_field(US%m_to_L_restart, "m_to_L", .false., CS%restart_CSp, & + "Length unit conversion factor", "L meter-1") if (CS%active_shelf_dynamics) then call register_restart_field(ISS%hmask, "h_mask", .true., CS%restart_CSp, & "ice sheet/shelf thickness mask" ,"none") @@ -1503,6 +1507,13 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl enddo ; enddo endif + if ((US%m_to_L_restart /= 0.0) .and. (US%m_to_L_restart /= US%m_to_L)) then + L_rescale = US%m_to_L / US%m_to_L_restart + do j=G%jsc,G%jec ; do i=G%isc,G%iec + ISS%area_shelf_h(i,j) = L_rescale**2 * ISS%area_shelf_h(i,j) + enddo ; enddo + endif + endif ! .not. new_sim CS%Time = Time @@ -1516,13 +1527,13 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl call cpu_clock_end(id_clock_pass) do j=jsd,jed ; do i=isd,ied - if (ISS%area_shelf_h(i,j) > US%L_to_m**2*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.") - ISS%area_shelf_h(i,j) = US%L_to_m**2*G%areaT(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) / (US%L_to_m**2*G%areaT(i,j)) + 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 @@ -1558,13 +1569,13 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl CS%id_area_shelf_h = register_diag_field('ocean_model', 'area_shelf_h', CS%diag%axesT1, CS%Time, & - 'Ice Shelf Area in cell', 'meter-2') + 'Ice Shelf Area in cell', 'meter-2', conversion=US%L_to_m**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', conversion=US%Z_to_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%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, & 'Ice Shelf Melt Rate', 'm yr-1') CS%id_thermal_driving = register_diag_field('ocean_model', 'thermal_driving', CS%diag%axesT1, CS%Time, & @@ -1695,7 +1706,7 @@ subroutine update_shelf_mass(G, CS, ISS, Time) 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%US%L_to_m**2*G%areaT(i,j) + ISS%area_shelf_h(i,j) = G%areaT(i,j) ISS%h_shelf(i,j) = ISS%mass_shelf(i,j) / CS%rho_ice ISS%hmask(i,j) = 1. endif diff --git a/src/ice_shelf/MOM_ice_shelf_dynamics.F90 b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 index 928221d276..a55f19ad86 100644 --- a/src/ice_shelf/MOM_ice_shelf_dynamics.F90 +++ b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 @@ -83,11 +83,11 @@ module MOM_ice_shelf_dynamics !! The exact form depends on basal law exponent and/or whether flow is "hybridized" a la Goldberg 2011 real, pointer, dimension(:,:) :: OD_rt => NULL() !< A running total for calculating OD_av. - real, pointer, dimension(:,:) :: float_frac_rt => NULL() !< A running total for calculating float_frac. + real, pointer, dimension(:,:) :: ground_frac_rt => NULL() !< A running total for calculating ground_frac. real, pointer, dimension(:,:) :: OD_av => NULL() !< The time average open ocean depth [Z ~> m]. - real, pointer, dimension(:,:) :: 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; obviously counterintuitive; might fix] + real, pointer, dimension(:,:) :: ground_frac => NULL() !< Fraction of the time a cell is "exposed", i.e. the column + !! thickness is below a threshold and interacting with the rock [nondim]. When this + !! is 1, the ice-shelf is grounded integer :: OD_rt_counter = 0 !< A counter of the number of contributions to OD_rt. real :: velocity_update_time_step !< The time interval over which to update the ice shelf velocity @@ -149,7 +149,7 @@ module MOM_ice_shelf_dynamics !>@{ 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_ground_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) @@ -237,7 +237,7 @@ subroutine register_ice_shelf_dyn_restarts(G, param_file, CS, restart_CS) 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 + allocate( CS%ground_frac(isd:ied,jsd:jed) ) ; CS%ground_frac(:,:) = 0.0 ! additional restarts for ice shelf state call register_restart_field(CS%u_shelf, "u_shelf", .false., restart_CS, & @@ -248,7 +248,7 @@ subroutine register_ice_shelf_dyn_restarts(G, param_file, CS, 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, & + call register_restart_field(CS%ground_frac, "ground_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)") @@ -276,7 +276,7 @@ subroutine initialize_ice_shelf_dyn(param_file, Time, ISS, CS, G, US, diag, new_ ! Local variables real :: Z_rescale ! A rescaling factor for heights from the representation in - ! a reastart fole to the internal representation in this run. + ! a restart file to the internal representation in this run. !This include declares and sets the variable "version". # include "version_variable.h" character(len=200) :: config @@ -420,7 +420,7 @@ subroutine initialize_ice_shelf_dyn(param_file, Time, ISS, CS, G, US, diag, new_ 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 + allocate( CS%ground_frac_rt(isd:ied,jsd:jed) ) ; CS%ground_frac_rt(:,:) = 0.0 if (CS%calve_to_mask) then allocate( CS%calve_mask(isd:ied,jsd:jed) ) ; CS%calve_mask(:,:) = 0.0 @@ -459,7 +459,7 @@ subroutine initialize_ice_shelf_dyn(param_file, Time, ISS, CS, G, US, diag, new_ endif call pass_var(CS%OD_av,G%domain) - call pass_var(CS%float_frac,G%domain) + call pass_var(CS%ground_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) @@ -513,8 +513,8 @@ subroutine initialize_ice_shelf_dyn(param_file, Time, ISS, CS, G, US, diag, new_ '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_ground_frac = register_diag_field('ocean_model','ice_ground_frac',CS%diag%axesT1, Time, & + 'fraction of cell that is grounded', 'none') CS%id_col_thick = register_diag_field('ocean_model','col_thick',CS%diag%axesT1, Time, & 'ocean column thickness passed to ice model', 'm', conversion=US%Z_to_m) CS%id_OD_av = register_diag_field('ocean_model','OD_av',CS%diag%axesT1, Time, & @@ -558,10 +558,10 @@ subroutine initialize_diagnostic_fields(CS, ISS, G, US, Time) 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. + CS%ground_frac(i,j) = 0. else CS%OD_av(i,j) = 0. - CS%float_frac(i,j) = 1. + CS%ground_frac(i,j) = 1. endif enddo enddo @@ -651,7 +651,7 @@ subroutine update_ice_shelf(CS, ISS, G, US, time_step, Time, ocean_mass, coupled 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_ground_frac > 0) call post_data(CS%id_ground_frac, CS%ground_frac,CS%diag) if (CS%id_OD_av >0) call post_data(CS%id_OD_av, CS%OD_av,CS%diag) if (CS%id_u_mask > 0) call post_data(CS%id_u_mask,CS%umask,CS%diag) @@ -849,7 +849,7 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u, v, iters, time) enddo if ((nodefloat > 0) .and. (nodefloat < 4)) then float_cond(i,j) = 1.0 - CS%float_frac(i,j) = 1.0 + CS%ground_frac(i,j) = 1.0 endif enddo enddo @@ -891,7 +891,7 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u, v, iters, time) ! 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) + CS%taub_beta_eff(i,j) = CS%taub_beta_eff(i,j) * CS%ground_frac(i,j) enddo ; enddo call apply_boundary_values(CS, ISS, G, time, Phisub, H_node, CS%ice_visc, & @@ -948,7 +948,7 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u, v, iters, time) ! 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) + CS%taub_beta_eff(i,j) = CS%taub_beta_eff(i,j) * CS%ground_frac(i,j) enddo ; enddo u_bdry_cont(:,:) = 0 ; v_bdry_cont(:,:) = 0 @@ -1896,7 +1896,9 @@ subroutine shelf_advance_front(CS, ISS, G, flux_enter) integer :: i_off, j_off integer :: iter_flag - real :: h_reference, dxh, dyh, dxdyh, rho, partial_vol, tot_flux + real :: h_reference, dxh, dyh, rho, tot_flux + real :: partial_vol ! The volume covered by ice shelf [m L2 ~> m3] + real :: dxdyh ! Cell area [L2 ~> m2] character(len=160) :: mesg ! The text of an error message integer, dimension(4) :: mapi, mapj, new_partial ! real, dimension(size(flux_enter,1),size(flux_enter,2),size(flux_enter,2)) :: flux_enter_replace @@ -1957,9 +1959,9 @@ subroutine shelf_advance_front(CS, ISS, G, flux_enter) enddo if (n_flux > 0) then - dxdyh = G%US%L_to_m**2*G%areaT(i,j) + 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 + partial_vol = ISS%h_shelf(i,j) * ISS%area_shelf_h(i,j) + G%US%m_to_L**2*tot_flux if ((partial_vol / dxdyh) == h_reference) then ! cell is exactly covered, no overflow ISS%hmask(i,j) = 1 @@ -1967,7 +1969,7 @@ subroutine shelf_advance_front(CS, ISS, G, flux_enter) 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%mass_shelf(i,j) = G%US%L_to_m**2*partial_vol * rho ISS%area_shelf_h(i,j) = partial_vol / h_reference ISS%h_shelf(i,j) = h_reference else @@ -1988,8 +1990,6 @@ subroutine shelf_advance_front(CS, ISS, G, flux_enter) 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 @@ -2005,11 +2005,9 @@ subroutine shelf_advance_front(CS, ISS, G, flux_enter) 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? + flux_enter_replace(i+2*k-3,j,3-k) = G%US%L_to_m**2*partial_vol / real(n_flux) if (new_partial(k+2) == 1) & - flux_enter_replace(i,j+2*k-3,5-k) = partial_vol / real(n_flux) + flux_enter_replace(i,j+2*k-3,5-k) = G%US%L_to_m**2*partial_vol / real(n_flux) enddo endif @@ -2037,12 +2035,10 @@ 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 [Z ~> m]. - real, dimension(SZDI_(G),SZDJ_(G)), & - intent(inout) :: area_shelf_h !< The area per cell covered by the ice shelf [m2]. - real, dimension(SZDI_(G),SZDJ_(G)), & - intent(inout) :: hmask !< A mask indicating which tracer points are + real, dimension(SZDI_(G),SZDJ_(G)), intent(inout) :: h_shelf !< The ice shelf thickness [Z ~> m]. + real, dimension(SZDI_(G),SZDJ_(G)), intent(inout) :: area_shelf_h !< The area per cell covered by + !! the ice shelf [L2 ~> 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 [Z ~> m]. @@ -2051,7 +2047,7 @@ subroutine ice_shelf_min_thickness_calve(G, h_shelf, area_shelf_h, hmask, thickn 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 +! (CS%ground_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 @@ -2064,16 +2060,13 @@ 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 [Z ~> m]. - real, dimension(SZDI_(G),SZDJ_(G)), & - intent(inout) :: area_shelf_h !< The area per cell covered by the ice shelf [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. + real, dimension(SZDI_(G),SZDJ_(G)), intent(inout) :: h_shelf !< The ice shelf thickness [Z ~> m]. + real, dimension(SZDI_(G),SZDJ_(G)), intent(inout) :: area_shelf_h !< The area per cell covered by + !! the ice shelf [L2 ~> 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 @@ -2235,7 +2228,7 @@ subroutine calc_shelf_driving_stress(CS, ISS, G, US, TAUD_X, TAUD_Y, OD) 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 + if (CS%ground_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 @@ -3066,7 +3059,7 @@ subroutine update_OD_ffrac(CS, G, US, ocean_mass, find_avg) 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 + CS%ground_frac_rt(i,j) = CS%ground_frac_rt(i,j) + 1.0 endif enddo ; enddo CS%OD_rt_counter = CS%OD_rt_counter + 1 @@ -3074,13 +3067,13 @@ subroutine update_OD_ffrac(CS, G, US, ocean_mass, find_avg) 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%ground_frac(i,j) = 1.0 - (CS%ground_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 + CS%OD_rt(i,j) = 0.0 ; CS%ground_frac_rt(i,j) = 0.0 enddo ; enddo - call pass_var(CS%float_frac, G%domain) + call pass_var(CS%ground_frac, G%domain) call pass_var(CS%OD_av, G%domain) endif @@ -3104,10 +3097,10 @@ subroutine update_OD_ffrac_uncoupled(CS, G, h_shelf) 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. + CS%ground_frac(i,j) = 0. else CS%OD_av(i,j) = 0. - CS%float_frac(i,j) = 1. + CS%ground_frac(i,j) = 1. endif enddo enddo @@ -3463,7 +3456,7 @@ subroutine ice_shelf_dyn_end(CS) 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%ground_frac, CS%ground_frac_rt) deallocate(CS) diff --git a/src/ice_shelf/MOM_ice_shelf_initialize.F90 b/src/ice_shelf/MOM_ice_shelf_initialize.F90 index 2ace1b2137..16eb923fd4 100644 --- a/src/ice_shelf/MOM_ice_shelf_initialize.F90 +++ b/src/ice_shelf/MOM_ice_shelf_initialize.F90 @@ -30,7 +30,7 @@ subroutine initialize_ice_thickness(h_shelf, area_shelf_h, hmask, G, US, PF) real, dimension(SZDI_(G),SZDJ_(G)), & intent(inout) :: h_shelf !< The ice shelf thickness [Z ~> m]. real, dimension(SZDI_(G),SZDJ_(G)), & - intent(inout) :: area_shelf_h !< The area per cell covered by the ice shelf [m2]. + intent(inout) :: area_shelf_h !< The area per cell covered by the ice shelf [L2 ~> 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 @@ -60,9 +60,9 @@ end subroutine initialize_ice_thickness subroutine initialize_ice_thickness_from_file(h_shelf, area_shelf_h, hmask, G, US, 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 [m]. + intent(inout) :: h_shelf !< The ice shelf thickness [Z ~> m]. real, dimension(SZDI_(G),SZDJ_(G)), & - intent(inout) :: area_shelf_h !< The area per cell covered by the ice shelf [m2]. + intent(inout) :: area_shelf_h !< The area per cell covered by the ice shelf [L2 ~> 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 @@ -70,7 +70,7 @@ subroutine initialize_ice_thickness_from_file(h_shelf, area_shelf_h, hmask, G, U 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 + ! h_shelf [Z ~> m] and area_shelf_h [L2 ~> m2] (and dimensionless) and updates hmask character(len=200) :: filename,thickness_file,inputdir ! Strings for file/path character(len=200) :: thickness_varname, area_varname ! Variable name in file character(len=40) :: mdl = "initialize_ice_thickness_from_file" ! This subroutine's name. @@ -101,7 +101,7 @@ subroutine initialize_ice_thickness_from_file(h_shelf, area_shelf_h, hmask, G, U " initialize_topography_from_file: Unable to open "//trim(filename)) call MOM_read_data(filename, trim(thickness_varname), h_shelf, G%Domain, scale=US%m_to_Z) - call MOM_read_data(filename,trim(area_varname),area_shelf_h,G%Domain) + call MOM_read_data(filename,trim(area_varname), area_shelf_h, G%Domain, scale=US%m_to_L**2) ! call get_param(PF, mdl, "ICE_BOUNDARY_CONFIG", config, & ! "This specifies how the ice domain boundary is specified", & @@ -120,7 +120,7 @@ subroutine initialize_ice_thickness_from_file(h_shelf, area_shelf_h, hmask, G, U udh = exp(-(G%geoLonCv(i,j)-len_sidestress)/5.0) * h_shelf(i,j) if (udh <= 25.0) then h_shelf(i,j) = 0.0 - area_shelf_h (i,j) = 0.0 + area_shelf_h(i,j) = 0.0 else h_shelf(i,j) = udh endif @@ -128,11 +128,11 @@ subroutine initialize_ice_thickness_from_file(h_shelf, area_shelf_h, hmask, G, U ! update thickness mask - if (area_shelf_h (i,j) >= US%L_to_m**2*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) == 0.0) then hmask(i,j) = 0. - elseif ((area_shelf_h(i,j) > 0) .and. (area_shelf_h(i,j) <= US%L_to_m**2*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") @@ -140,7 +140,6 @@ subroutine initialize_ice_thickness_from_file(h_shelf, area_shelf_h, hmask, G, U enddo enddo - end subroutine initialize_ice_thickness_from_file !> Initialize ice shelf thickness for a channel configuration @@ -149,7 +148,7 @@ subroutine initialize_ice_thickness_channel(h_shelf, area_shelf_h, hmask, G, US, real, dimension(SZDI_(G),SZDJ_(G)), & intent(inout) :: h_shelf !< The ice shelf thickness [Z ~> m]. real, dimension(SZDI_(G),SZDJ_(G)), & - intent(inout) :: area_shelf_h !< The area per cell covered by the ice shelf [m2]. + intent(inout) :: area_shelf_h !< The area per cell covered by the ice shelf [L2 ~> 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 @@ -206,11 +205,11 @@ subroutine initialize_ice_thickness_channel(h_shelf, area_shelf_h, hmask, G, US, h_shelf (i,j) = 0.0 else if (G%geoLonCu(i,j) > edge_pos) then - area_shelf_h(i,j) = US%L_to_m**2*G%areaT(i,j) * (edge_pos - G%geoLonCu(i-1,j)) / & - (G%geoLonCu(i,j) - G%geoLonCu(i-1,j)) + area_shelf_h(i,j) = G%areaT(i,j) * (edge_pos - G%geoLonCu(i-1,j)) / & + (G%geoLonCu(i,j) - G%geoLonCu(i-1,j)) hmask (i,j) = 2.0 else - area_shelf_h(i,j) = US%L_to_m**2*G%areaT(i,j) + area_shelf_h(i,j) = G%areaT(i,j) hmask (i,j) = 1.0 endif diff --git a/src/ice_shelf/MOM_ice_shelf_state.F90 b/src/ice_shelf/MOM_ice_shelf_state.F90 index 414a3389d6..91e9a41687 100644 --- a/src/ice_shelf/MOM_ice_shelf_state.F90 +++ b/src/ice_shelf/MOM_ice_shelf_state.F90 @@ -24,7 +24,7 @@ module MOM_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 [kg m-2]. - area_shelf_h => NULL(), & !< The area per cell covered by the ice shelf [m2]. + area_shelf_h => NULL(), & !< The area per cell covered by the ice shelf [L2 ~> m2]. h_shelf => NULL(), & !< the thickness of the shelf [m], redundant with mass but may !! make the code more readable hmask => NULL(),& !< Mask used to indicate ice-covered or partiall-covered cells diff --git a/src/ice_shelf/user_shelf_init.F90 b/src/ice_shelf/user_shelf_init.F90 index c0c7c96a59..100f8e652a 100644 --- a/src/ice_shelf/user_shelf_init.F90 +++ b/src/ice_shelf/user_shelf_init.F90 @@ -49,7 +49,7 @@ subroutine USER_initialize_shelf_mass(mass_shelf, area_shelf_h, h_shelf, hmask, real, dimension(SZDI_(G),SZDJ_(G)), & intent(out) :: h_shelf !< The ice shelf thickness [Z ~> m]. real, dimension(SZDI_(G),SZDJ_(G)), & - intent(out) :: area_shelf_h !< The area per cell covered by the ice shelf [m2]. + intent(out) :: area_shelf_h !< The area per cell covered by the ice shelf [L2 ~> 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 @@ -105,7 +105,7 @@ subroutine USER_init_ice_thickness(h_shelf, area_shelf_h, hmask, G, US, param_fi real, dimension(SZDI_(G),SZDJ_(G)), & intent(out) :: h_shelf !< The ice shelf thickness [m]. real, dimension(SZDI_(G),SZDJ_(G)), & - intent(out) :: area_shelf_h !< The area per cell covered by the ice shelf [m2]. + intent(out) :: area_shelf_h !< The area per cell covered by the ice shelf [L2 ~> 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 @@ -128,7 +128,7 @@ subroutine USER_update_shelf_mass(mass_shelf, area_shelf_h, h_shelf, hmask, G, C intent(inout) :: mass_shelf !< The ice shelf mass per unit area averaged !! over the full ocean cell [kg m-2]. real, dimension(SZDI_(G),SZDJ_(G)), & - intent(inout) :: area_shelf_h !< The area per cell covered by the ice shelf [m2]. + intent(inout) :: area_shelf_h !< The area per cell covered by the ice shelf [L2 ~> m2]. real, dimension(SZDI_(G),SZDJ_(G)), & intent(inout) :: h_shelf !< The ice shelf thickness [Z ~> m]. real, dimension(SZDI_(G),SZDJ_(G)), & @@ -168,11 +168,11 @@ subroutine USER_update_shelf_mass(mass_shelf, area_shelf_h, h_shelf, hmask, G, C h_shelf (i,j) = 0.0 else if (G%geoLonCu(i,j) > edge_pos) then - area_shelf_h(i,j) = G%US%L_to_m**2*G%areaT(i,j) * (edge_pos - G%geoLonCu(i-1,j)) / & + area_shelf_h(i,j) = G%areaT(i,j) * (edge_pos - G%geoLonCu(i-1,j)) / & (G%geoLonCu(i,j) - G%geoLonCu(i-1,j)) hmask (i,j) = 2.0 else - area_shelf_h(i,j) = G%US%L_to_m**2*G%areaT(i,j) + area_shelf_h(i,j) = G%areaT(i,j) hmask (i,j) = 1.0 endif From 1160c6bd70900c9d5ad4cd2a9380741672002342 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sat, 21 Mar 2020 14:37:08 -0400 Subject: [PATCH 116/316] +Rescaled forcing%ice_shelf_melt and ice_shelf variables Rescale the units of forcing%ice_shelf melt and added dimensional rescaling to various internal ice_shelf variables, including heat capacities, densities, latent heat coefficients and ISS%water_flux. Also canceled out common rescaling factors. All answers in the MOM6-examples test cases are bitwise identical, including the ISOMIP test case. --- src/core/MOM_forcing_type.F90 | 2 +- src/ice_shelf/MOM_ice_shelf.F90 | 130 ++++++++++++----------- src/ice_shelf/MOM_ice_shelf_dynamics.F90 | 19 ++-- src/ice_shelf/MOM_ice_shelf_state.F90 | 2 +- src/ice_shelf/MOM_marine_ice.F90 | 29 +++-- src/tracer/ISOMIP_tracer.F90 | 5 +- 6 files changed, 94 insertions(+), 93 deletions(-) diff --git a/src/core/MOM_forcing_type.F90 b/src/core/MOM_forcing_type.F90 index 167ae0581d..ebafa1d47a 100644 --- a/src/core/MOM_forcing_type.F90 +++ b/src/core/MOM_forcing_type.F90 @@ -149,7 +149,7 @@ module MOM_forcing_type !! associated if ice shelves are enabled, and are !! exactly 0 away from shelves or on land. real, pointer, dimension(:,:) :: iceshelf_melt => NULL() !< Ice shelf melt rate (positive) - !! or freezing (negative) [m year-1] + !! or freezing (negative) [Z year-1 ~> m year-1] ! Scalars set by surface forcing modules real :: vPrecGlobalAdj = 0. !< adjustment to restoring vprec to zero out global net [kg m-2 s-1] diff --git a/src/ice_shelf/MOM_ice_shelf.F90 b/src/ice_shelf/MOM_ice_shelf.F90 index e262d35c74..5a7befbea7 100644 --- a/src/ice_shelf/MOM_ice_shelf.F90 +++ b/src/ice_shelf/MOM_ice_shelf.F90 @@ -91,20 +91,20 @@ module MOM_ice_shelf real :: ustar_bg !< A minimum value for ustar under ice shelves [Z T-1 ~> m s-1]. real :: cdrag !< drag coefficient under ice shelves [nondim]. real :: g_Earth !< The gravitational acceleration [m s-2] - real :: Cp !< The heat capacity of sea water [J kg-1 degC-1]. + real :: Cp !< The heat capacity of sea water [Q degC-1 ~> J kg-1 degC-1]. real :: Rho0 !< A reference ocean density [kg m-3]. - real :: Cp_ice !< The heat capacity of fresh ice [J kg-1 degC-1]. + real :: Cp_ice !< The heat capacity of fresh ice [Q degC-1 ~> J kg-1 degC-1]. real :: gamma_t !< The (fixed) turbulent exchange velocity in the !< 2-equation formulation [m s-1]. real :: Salin_ice !< The salinity of shelf ice [ppt]. real :: Temp_ice !< The core temperature of shelf ice [degC]. real :: kv_ice !< The viscosity of ice [m2 s-1]. - real :: density_ice !< A typical density of ice [kg m-3]. + real :: density_ice !< A typical density of ice [R ~> kg m-3]. real :: rho_ice !< Nominal ice density [kg m-2 Z-1 ~> 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 [m2 s-1]. real :: kd_molec_temp!< The molecular diffusivity of heat [m2 s-1]. - real :: Lat_fusion !< The latent heat of fusion [J kg-1]. + real :: Lat_fusion !< The latent heat of fusion [Q ~> J kg-1]. real :: Gamma_T_3EQ !< Nondimensional heat-transfer coefficient, used in the 3Eq. formulation !< This number should be specified by the user. real :: col_thick_melt_threshold !< if the mixed layer is below this threshold, melt rate @@ -222,7 +222,7 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) exch_vel_s !< Sub-shelf salt exchange velocity [m s-1] real, dimension(SZDI_(CS%grid),SZDJ_(CS%grid)) :: & - mass_flux !< total mass flux of freshwater across + mass_flux !< Total mass flux of freshwater across the ice-ocean interface. [R Z L2 T-1 ~> kg/s] real, dimension(SZDI_(CS%grid),SZDJ_(CS%grid)) :: & haline_driving !< (SSS - S_boundary) ice-ocean !! interface, positive for melting and negative for freezing. @@ -232,7 +232,8 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) !! viscosity is linearly increasing. (Was 1/8. Why?) real, parameter :: RC = 0.20 ! critical flux Richardson number. real :: I_ZETA_N !< The inverse of ZETA_N. - real :: LF, I_LF !< Latent Heat of fusion [J kg-1] and its inverse. + real :: LF !< Latent Heat of fusion [J kg-1]. + real :: I_LF !< The inverse of the latent Heat of fusion [Q-1 ~> kg J-1]. real :: I_VK !< The inverse of VK. real :: PR, SC !< The Prandtl number and Schmidt number [nondim]. @@ -250,14 +251,15 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) real :: wB_flux !< The vertical flux of heat just inside the ocean [m2 s-3]. real :: dB_dS !< The derivative of buoyancy with salinity [m s-2 ppt-1]. real :: dB_dT !< The derivative of buoyancy with temperature [m s-2 degC-1]. - real :: I_n_star, n_star_term, absf + real :: I_n_star, n_star_term + real :: absf ! The absolute value of the Coriolis parameter [T-1 ~> s-1] real :: dIns_dwB !< The partial derivative of I_n_star with wB_flux, in ???. real :: dT_ustar, dS_ustar - real :: ustar_h + real :: ustar_h ! The friction velocity in the water below the ice shelf [Z T-1 ~> m s-1] real :: Gam_turb real :: Gam_mol_t, Gam_mol_s - real :: RhoCp - real :: I_RhoLF + real :: RhoCp ! A typical ocean density times the heat capacity of water [Q R ~> J m-3] +!### real :: I_RhoLF ! The inverse of the ocean density times the latent heat of fusion [Q-1 R-1 ~> m3 J-1] real :: ln_neut real :: mass_exch real :: Sb_min, Sb_max @@ -286,13 +288,13 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) ! 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 - I_RhoLF = 1.0/(CS%Rho0*LF) - I_LF = 1.0 / LF + LF = US%Q_to_J_kg*CS%Lat_fusion +!### I_RhoLF = 1.0/(CS%Rho0*US%Q_to_J_kg*CS%Lat_fusion) + I_LF = 1.0 / CS%Lat_fusion SC = CS%kv_molec/CS%kd_molec_salt PR = CS%kv_molec/CS%kd_molec_temp I_VK = 1.0/VK - RhoCp = CS%Rho0 * CS%Cp + RhoCp = US%kg_m3_to_R*CS%Rho0 * CS%Cp Isqrt2 = 1.0/sqrt(2.0) !first calculate molecular component @@ -369,23 +371,23 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) fluxes%ustar_shelf(i,j) = MAX(CS%ustar_bg, US%m_to_Z*US%T_to_s * & sqrt(CS%cdrag*((u_at_h**2 + v_at_h**2) + CS%utide(i,j)**1))) - ustar_h = US%Z_to_m*US%s_to_T*fluxes%ustar_shelf(i,j) + ustar_h = fluxes%ustar_shelf(i,j) ! I think that the following can be deleted without causing any problems. ! if (allocated(state%taux_shelf) .and. allocated(state%tauy_shelf)) then ! ! These arrays are supposed to be stress components at C-grid points, which is ! ! inconsistent with what is coded up here. - ! state%taux_shelf(i,j) = ustar_h*ustar_h*CS%Rho0*Isqrt2 + ! state%taux_shelf(i,j) = US%Z_to_m**2*US%s_to_T**2*ustar_h**2 * CS%Rho0*Isqrt2 ! state%tauy_shelf(i,j) = state%taux_shelf(i,j) ! endif ! Estimate the neutral ocean boundary layer thickness as the minimum of the ! reported ocean mixed layer thickness and the neutral Ekman depth. - absf = 0.25*US%s_to_T*((abs(US%s_to_T*G%CoriolisBu(I,J)) + abs(US%s_to_T*G%CoriolisBu(I-1,J-1))) + & - (abs(US%s_to_T*G%CoriolisBu(I,J-1)) + abs(US%s_to_T*G%CoriolisBu(I-1,J)))) - if (absf*state%Hml(i,j) <= VK*ustar_h) then ; hBL_neut = state%Hml(i,j) - else ; hBL_neut = (VK*ustar_h) / absf ; endif - hBL_neut_h_molec = ZETA_N * ((hBL_neut * ustar_h) / (5.0 * CS%Kv_molec)) + absf = 0.25*((abs(G%CoriolisBu(I,J)) + abs(G%CoriolisBu(I-1,J-1))) + & + (abs(G%CoriolisBu(I,J-1)) + abs(G%CoriolisBu(I-1,J)))) + if (absf*US%Z_to_m*state%Hml(i,j) <= VK*ustar_h) then ; hBL_neut = state%Hml(i,j) + else ; hBL_neut = US%Z_to_m*(VK*ustar_h) / absf ; endif + hBL_neut_h_molec = ZETA_N * ((hBL_neut * US%Z_to_m*US%s_to_T*ustar_h) / (5.0 * CS%Kv_molec)) ! Determine the mixed layer buoyancy flux, wB_flux. dB_dS = (CS%g_Earth / Rhoml(i)) * dR0_dS(i) @@ -395,11 +397,11 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) if (CS%find_salt_root) then ! read liquidus parameters - S_a = CS%lambda1 * CS%Gamma_T_3EQ * CS%Cp + S_a = CS%lambda1 * CS%Gamma_T_3EQ * US%Q_to_J_kg*CS%Cp ! S_b = -CS%Gamma_T_3EQ*(CS%lambda2-CS%lambda3*p_int(i)-state%sst(i,j)) & ! -LF*CS%Gamma_T_3EQ/35.0 - S_b = CS%Gamma_T_3EQ*CS%Cp*(CS%lambda2+CS%lambda3*p_int(i)- & + S_b = CS%Gamma_T_3EQ*US%Q_to_J_kg*CS%Cp*(CS%lambda2+CS%lambda3*p_int(i)- & state%sst(i,j))-LF*CS%Gamma_T_3EQ/35.0 S_c = LF*(CS%Gamma_T_3EQ/35.0)*state%sss(i,j) @@ -425,8 +427,8 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) ! Determine the potential temperature at the ice-ocean interface. call calculate_TFreeze(Sbdry(i,j), p_int(i), ISS%tfreeze(i,j), CS%eqn_of_state) - dT_ustar = (state%sst(i,j) - ISS%tfreeze(i,j)) * ustar_h - dS_ustar = (state%sss(i,j) - Sbdry(i,j)) * ustar_h + dT_ustar = (state%sst(i,j) - ISS%tfreeze(i,j)) * US%Z_to_m*US%s_to_T*ustar_h + dS_ustar = (state%sss(i,j) - Sbdry(i,j)) * US%Z_to_m*US%s_to_T*ustar_h ! First, determine the buoyancy flux assuming no effects of stability ! on the turbulence. Following H & J '99, this limit also applies @@ -448,7 +450,7 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) if (wB_flux > 0.0) then ! The buoyancy flux is stabilizing and will reduce the tubulent ! fluxes, and iteration is required. - n_star_term = (ZETA_N/RC) * (hBL_neut * VK) / ustar_h**3 + n_star_term = (ZETA_N/RC) * (hBL_neut * VK) / (US%Z_to_m*US%s_to_T*ustar_h)**3 do it3 = 1,30 ! n_star <= 1.0 is the ratio of working boundary layer thickness ! to the neutral thickness. @@ -492,9 +494,9 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) enddo !it3 endif - 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 + ISS%tflux_ocn(i,j) = US%R_to_kg_m3*US%Q_to_J_kg*RhoCp * wT_flux + exch_vel_t(i,j) = US%Z_to_m*US%s_to_T*ustar_h * I_Gam_T + exch_vel_s(i,j) = US%Z_to_m*US%s_to_T*ustar_h * I_Gam_S !Calculate the heat flux inside the ice shelf. @@ -505,23 +507,23 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) !If this approximation is not made, iterations are required... See H+J Fig 3. 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%water_flux(i,j) = US%W_m2_to_QRZ_T * I_LF * ISS%tflux_ocn(i,j) ISS%tflux_shelf(i,j) = 0.0 else if (CS%insulator) then !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)) + ISS%water_flux(i,j) = US%W_m2_to_QRZ_T * 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 + 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) / & + ISS%water_flux(i,j) = US%kg_m2s_to_RZ_T * 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) + ISS%tflux_shelf(i,j) = ISS%tflux_ocn(i,j) - LF*US%RZ_T_to_kg_m2s*ISS%water_flux(i,j) endif endif @@ -535,8 +537,8 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) else mass_exch = exch_vel_s(i,j) * CS%Rho0 - Sbdry_it = (state%sss(i,j) * mass_exch + CS%Salin_ice * & - ISS%water_flux(i,j)) / (mass_exch + ISS%water_flux(i,j)) + Sbdry_it = (state%sss(i,j) * mass_exch + CS%Salin_ice * US%RZ_T_to_kg_m2s*ISS%water_flux(i,j)) / & + (mass_exch + US%RZ_T_to_kg_m2s*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 @@ -574,9 +576,9 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) call calculate_TFreeze(state%sss(i,j), p_int(i), ISS%tfreeze(i,j), CS%eqn_of_state) 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_ocn(i,j) = US%R_to_kg_m3*US%Q_to_J_kg*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) + ISS%water_flux(i,j) = US%W_m2_to_QRZ_T * I_LF * ISS%tflux_ocn(i,j) Sbdry(i,j) = 0.0 endif else !not shelf @@ -588,12 +590,12 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) enddo ! i-loop enddo ! j-loop - ! ISS%water_flux = net liquid water into the ocean ( kg/(m^2 s) ) + ! ISS%water_flux = net liquid water into the ocean [R Z T-1 ~> kg m-2 s-1] ! We want melt in m/year if (CS%const_gamma) then ! use ISOMIP+ eq. with rho_fw - fluxes%iceshelf_melt = ISS%water_flux * (86400.0*365.0/rho_fw) * CS%flux_factor + fluxes%iceshelf_melt = ISS%water_flux * (86400.0*365.0*US%s_to_T/rho_fw) * CS%flux_factor else ! use original eq. - fluxes%iceshelf_melt = ISS%water_flux * (86400.0*365.0/CS%density_ice) * CS%flux_factor + fluxes%iceshelf_melt = ISS%water_flux * (86400.0*365.0*US%s_to_T/CS%density_ice) * CS%flux_factor endif do j=js,je ; do i=is,ie @@ -610,7 +612,7 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) 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)) / & + haline_driving(i,j) = (US%RZ_T_to_kg_m2s*ISS%water_flux(i,j) * Sbdry(i,j)) / & (CS%Rho0 * exch_vel_s(i,j)) !!!!!!!!!!!!!!!!!!!!!!!!!!!!Safety checks !!!!!!!!!!!!!!!!!!!!!!!!! @@ -637,7 +639,7 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) ! mass flux [kg s-1], part of ISOMIP diags. mass_flux(:,:) = 0.0 - mass_flux(:,:) = ISS%water_flux(:,:) * US%L_to_m**2*ISS%area_shelf_h(:,:) + mass_flux(:,:) = ISS%water_flux(:,:) * ISS%area_shelf_h(:,:) if (CS%active_shelf_dynamics .or. CS%override_shelf_movement) then call cpu_clock_begin(id_clock_pass) @@ -727,8 +729,8 @@ subroutine change_thickness_using_melt(ISS, G, time_step, fluxes, rho_ice, debug 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 + if (G%US%RZ_T_to_kg_m2s*ISS%water_flux(i,j) * time_step / rho_ice < ISS%h_shelf(i,j)) then + ISS%h_shelf(i,j) = ISS%h_shelf(i,j) - G%US%RZ_T_to_kg_m2s*ISS%water_flux(i,j) * time_step / rho_ice 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 @@ -815,7 +817,7 @@ subroutine add_shelf_forces(G, US, CS, forces, do_shelf_area) ! 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 + kv_rho_ice = CS%kv_ice / (US%R_to_kg_m3*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) + & @@ -900,7 +902,7 @@ subroutine add_shelf_flux(G, US, CS, state, fluxes) !! the ice-shelf state real :: kv_rho_ice ! The viscosity of ice divided by its density [m5 kg-1 s-1] - real, parameter :: rho_fw = 1000.0 ! fresh water density + real :: rho_fw = 1000.0 ! Fresh water density [R ~> kg m-3] character(len=160) :: mesg ! The text of an error message integer :: i, j, is, ie, js, je, isd, ied, jsd, jed is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec @@ -912,6 +914,8 @@ subroutine add_shelf_flux(G, US, CS, state, fluxes) ISS => CS%ISS + rho_fw = 1000.0*US%kg_m3_to_R ! fresh water density + call add_shelf_pressure(G, US, CS, fluxes) ! Determine ustar and the square magnitude of the velocity in the @@ -967,10 +971,10 @@ subroutine add_shelf_flux(G, US, CS, state, fluxes) 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) = US%kg_m2s_to_RZ_T*frac_area*ISS%water_flux(i,j)*CS%flux_factor + 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) = US%kg_m2s_to_RZ_T*frac_area*ISS%water_flux(i,j)*CS%flux_factor + fluxes%evap(i,j) = frac_area*ISS%water_flux(i,j)*CS%flux_factor endif endif @@ -998,7 +1002,7 @@ subroutine add_shelf_flux(G, US, CS, state, fluxes) do j=js,je ; do i=is,ie frac_area = fluxes%frac_shelf_h(i,j) if (frac_area > 0.0) & - mean_melt_flux = mean_melt_flux + (ISS%water_flux(i,j)) * US%L_to_m**2*ISS%area_shelf_h(i,j) + mean_melt_flux = mean_melt_flux + (ISS%water_flux(i,j)) * US%RZ_T_to_kg_m2s*US%L_to_m**2*ISS%area_shelf_h(i,j) !### 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 @@ -1037,9 +1041,8 @@ subroutine add_shelf_flux(G, US, CS, state, fluxes) 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 -! write(mesg,*)'delta_mass_shelf = ',delta_mass_shelf +! delta_mass_shelf = (shelf_mass1 - shelf_mass0) * (rho_fw/(CS%density_ice*CS%time_step)) +! write(mesg,*) 'delta_mass_shelf = ', delta_mass_shelf ! call MOM_mesg(mesg,5) else! first time step delta_mass_shelf = 0.0 @@ -1058,10 +1061,10 @@ subroutine add_shelf_flux(G, US, CS, state, 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%vprec(i,j) = -mean_melt_flux * US%R_to_kg_m3*CS%density_ice/1000. ! evap is negative ! Rescale fluxes%vprec to the proper units. fluxes%vprec(i,j) = US%kg_m2s_to_RZ_T * fluxes%vprec(i,j) - fluxes%sens(i,j) = fluxes%vprec(i,j) * US%J_kg_to_Q*CS%Cp * CS%T0 ! [ Q R Z T-1 ~> W /m^2 ] + fluxes%sens(i,j) = fluxes%vprec(i,j) * US%J_kg_to_Q*US%Q_to_J_kg*CS%Cp * CS%T0 ! [ Q R Z T-1 ~> 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 @@ -1170,7 +1173,7 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl isd = G%isd ; jsd = G%jsd ; ied = G%ied ; jed = G%jed Isdq = G%IsdB ; Iedq = G%IedB ; Jsdq = G%JsdB ; Jedq = G%JedB - CS%Lat_fusion = 3.34e5 + CS%Lat_fusion = 3.34e5*US%J_kg_to_Q CS%override_shelf_movement = .false. ; CS%active_shelf_dynamics = .false. call log_version(param_file, mdl, version, "") @@ -1271,7 +1274,7 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl "The gravitational acceleration of the Earth.", & units="m s-2", default = 9.80) call get_param(param_file, mdl, "C_P", CS%Cp, & - "The heat capacity of sea water.", units="J kg-1 K-1", & + "The heat capacity of sea water.", units="J kg-1 K-1", scale=US%J_kg_to_Q, & fail_if_missing=.true.) call get_param(param_file, mdl, "RHO_0", CS%Rho0, & "The mean ocean density used with BOUSSINESQ true to "//& @@ -1280,7 +1283,7 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl "parameters from vertical units of m to kg m-2.", & units="kg m-3", default=1035.0) !### MAKE THIS A SEPARATE PARAMETER. call get_param(param_file, mdl, "C_P_ICE", CS%Cp_ice, & - "The heat capacity of ice.", units="J kg-1 K-1", & + "The heat capacity of ice.", units="J kg-1 K-1", scale=US%J_kg_to_Q, & default=2.10e3) call get_param(param_file, mdl, "ICE_SHELF_FLUX_FACTOR", CS%flux_factor, & @@ -1345,7 +1348,7 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl 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) + "A typical density of ice.", units="kg m-3", default=917.0, scale=US%kg_m3_to_R) call get_param(param_file, mdl, "INPUT_FLUX_ICE_SHELF", CS%input_flux, & "volume flux at upstream boundary", units="m2 s-1", default=0.) @@ -1354,9 +1357,9 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl else ! This is here because of inconsistent defaults. I don't know why. RWH call get_param(param_file, mdl, "DENSITY_ICE", CS%density_ice, & - "A typical density of ice.", units="kg m-3", default=900.0) + "A typical density of ice.", units="kg m-3", default=900.0, scale=US%kg_m3_to_R) endif - CS%rho_ice = CS%density_ice*US%Z_to_m + CS%rho_ice = CS%density_ice*US%Z_to_m*US%R_to_kg_m3 call get_param(param_file, mdl, "MIN_THICKNESS_SIMPLE_CALVE", & CS%min_thickness_simple_calve, & "Min thickness rule for the very simple calving law",& @@ -1439,8 +1442,6 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl !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 @@ -1575,9 +1576,10 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl CS%id_h_shelf = register_diag_field('ocean_model', 'h_shelf', CS%diag%axesT1, CS%Time, & 'ice shelf thickness', 'm', conversion=US%Z_to_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%Time, 'Total mass flux of freshwater across the ice-ocean interface.', & + 'kg/s', conversion=US%RZ_T_to_kg_m2s*US%L_to_m**2) CS%id_melt = register_diag_field('ocean_model', 'melt', CS%diag%axesT1, CS%Time, & - 'Ice Shelf Melt Rate', 'm yr-1') + 'Ice Shelf Melt Rate', 'm yr-1', conversion=US%Z_to_m) CS%id_thermal_driving = register_diag_field('ocean_model', 'thermal_driving', CS%diag%axesT1, CS%Time, & 'pot. temp. in the boundary layer minus freezing pot. temp. at the ice-ocean interface.', 'Celsius') CS%id_haline_driving = register_diag_field('ocean_model', 'haline_driving', CS%diag%axesT1, CS%Time, & diff --git a/src/ice_shelf/MOM_ice_shelf_dynamics.F90 b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 index a55f19ad86..cf82092dc5 100644 --- a/src/ice_shelf/MOM_ice_shelf_dynamics.F90 +++ b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 @@ -3472,7 +3472,7 @@ subroutine ice_shelf_temp(CS, ISS, G, US, time_step, melt_rate, Time) type(unit_scale_type), intent(in) :: US !< Pointer to a structure containing unit conversion factors real, intent(in) :: time_step !< The time step for this update [s]. real, dimension(SZDI_(G),SZDJ_(G)), & - intent(in) :: melt_rate !< basal melt rate [kg m-2 s-1] + intent(in) :: melt_rate !< basal melt rate [R Z T-1 ~> kg m-2 s-1] type(time_type), intent(in) :: Time !< The current model time ! 5/23/12 OVS @@ -3507,12 +3507,15 @@ subroutine ice_shelf_temp(CS, ISS, G, US, time_step, melt_rate, Time) 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 + real :: rho, t_bd, Tsurf + real :: spy ! The amount of time in a year [T ~> s] + real :: adot ! A surface heat exchange coefficient [Z T-1 ~> m s-1]. rho = CS%density_ice - spy = 365 * 86400 ! seconds per year; is there a global constant for this? No - it is dependent upon a calendar. + spy = 365. * 86400. * US%s_to_T - adot = 0.1*US%m_to_Z/spy ! for now adot and Tsurf are defined here adot=surf acc 0.1m/yr, Tsurf=-20oC, vary them later + ! For now adot and Tsurf are defined here adot=surf acc 0.1m/yr, Tsurf=-20oC, vary them later + adot = 0.1*US%m_to_Z / spy Tsurf = -20.0 isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed @@ -3546,8 +3549,8 @@ subroutine ice_shelf_temp(CS, ISS, G, US, time_step, melt_rate, Time) ! 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) + call ice_shelf_advect_temp_x(CS, G, US%s_to_T*time_step/spy, ISS%hmask, TH, th_after_uflux, flux_enter) + call ice_shelf_advect_temp_y(CS, G, US%s_to_T*time_step/spy, ISS%hmask, th_after_uflux, th_after_vflux, flux_enter) do j=jsd,jed do i=isd,ied @@ -3576,9 +3579,9 @@ subroutine ice_shelf_temp(CS, ISS, G, US, time_step, melt_rate, Time) 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 - US%m_to_Z*melt_rate(i,j)*ISS%tfreeze(i,j))/(ISS%h_shelf(i,j)) +! US%s_to_T*time_step*(adot*Tsurf - US%R_to_kg_m3*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.0*US%m_to_Z/spy)*ISS%tfreeze(i,j)) / ISS%h_shelf(i,j) + US%s_to_T*time_step*(adot*Tsurf - (3.0*US%m_to_Z/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 diff --git a/src/ice_shelf/MOM_ice_shelf_state.F90 b/src/ice_shelf/MOM_ice_shelf_state.F90 index 91e9a41687..ac34817482 100644 --- a/src/ice_shelf/MOM_ice_shelf_state.F90 +++ b/src/ice_shelf/MOM_ice_shelf_state.F90 @@ -42,7 +42,7 @@ module MOM_ice_shelf_state salt_flux => NULL(), & !< The downward salt flux at the ocean-ice !! interface [kg m-2 s-1]. water_flux => NULL(), & !< The net downward liquid water flux at the - !! ocean-ice interface [kg m-2 s-1]. + !! ocean-ice interface [R Z T-1 ~> kg m-2 s-1]. tflux_shelf => NULL(), & !< The UPWARD diffusive heat flux in the ice !! shelf at the ice-ocean interface [W m-2]. diff --git a/src/ice_shelf/MOM_marine_ice.F90 b/src/ice_shelf/MOM_marine_ice.F90 index 4e3ce7401e..780cc8c3cd 100644 --- a/src/ice_shelf/MOM_marine_ice.F90 +++ b/src/ice_shelf/MOM_marine_ice.F90 @@ -30,7 +30,7 @@ module MOM_marine_ice 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 [J kg-1] + real :: latent_heat_fusion !< Latent heat of fusion [Q ~> J kg-1] real :: density_iceberg !< A typical density of icebergs [kg m-3] (for ice rigidity) type(time_type), pointer :: Time !< A pointer to the ocean model's clock. @@ -42,8 +42,7 @@ module MOM_marine_ice !> 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) +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 @@ -81,18 +80,16 @@ subroutine iceberg_forces(G, forces, use_ice_shelf, sfc_state, & 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%US%L_to_m**2*G%areaT(i,j)) + & - (forces%area_berg(i+1,j)*G%US%L_to_m**2*G%areaT(i+1,j))) / & - (G%US%L_to_m**2*G%areaT(i,j) + G%US%L_to_m**2*G%areaT(i+1,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%US%L_to_m**2*G%areaT(i,j)) + & - (forces%area_berg(i,j+1)*G%US%L_to_m**2*G%areaT(i,j+1))) / & - (G%US%L_to_m**2*G%areaT(i,j) + G%US%L_to_m**2*G%areaT(i,j+1)) ) + (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 @@ -101,8 +98,7 @@ 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, US, fluxes, use_ice_shelf, sfc_state, & - time_step, CS) +subroutine iceberg_fluxes(G, US, fluxes, use_ice_shelf, sfc_state, time_step, CS) type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(forcing), intent(inout) :: fluxes !< A structure with pointers to themodynamic, @@ -114,7 +110,8 @@ subroutine iceberg_fluxes(G, US, fluxes, use_ice_shelf, sfc_state, & type(marine_ice_CS), pointer :: CS !< Pointer to the control structure for MOM_marine_ice real :: fraz ! refreezing rate [R Z T-1 ~> kg m-2 s-1] - real :: I_dt_LHF ! The inverse of the timestep times the latent heat of fusion [kg J-1 T-1 ~> kg J-1 s-1]. + real :: I_dt_LHF ! The inverse of the timestep times the latent heat of fusion times unit conversion + ! factors because sfc_state is in MKS units [R Z m2 J-1 T-1 ~> 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 @@ -142,7 +139,7 @@ subroutine iceberg_fluxes(G, US, fluxes, use_ice_shelf, sfc_state, & !Zero'ing out other fluxes under the tabular icebergs if (CS%berg_area_threshold >= 0.) then - I_dt_LHF = 1.0 / (US%s_to_T*time_step * CS%latent_heat_fusion) + I_dt_LHF = US%W_m2_to_QRZ_T / (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. @@ -157,7 +154,7 @@ subroutine iceberg_fluxes(G, US, fluxes, use_ice_shelf, sfc_state, & ! control structure for diagnostic purposes. if (allocated(sfc_state%frazil)) then - fraz = US%kg_m3_to_R*US%m_to_Z*sfc_state%frazil(i,j) * I_dt_LHF + fraz = sfc_state%frazil(i,j) * I_dt_LHF if (associated(fluxes%evap)) fluxes%evap(i,j) = fluxes%evap(i,j) - fraz ! if (associated(fluxes%lprec)) fluxes%lprec(i,j) = fluxes%lprec(i,j) - fraz sfc_state%frazil(i,j) = 0.0 @@ -193,11 +190,11 @@ subroutine marine_ice_init(Time, G, param_file, diag, CS) 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) + "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) + "The latent heat of fusion.", units="J/kg", default=hlf, scale=G%US%J_kg_to_Q) call get_param(param_file, mdl, "BERG_AREA_THRESHOLD", CS%berg_area_threshold, & "Fraction of grid cell which iceberg must occupy, so that fluxes "//& "below berg are set to zero. Not applied for negative "//& diff --git a/src/tracer/ISOMIP_tracer.F90 b/src/tracer/ISOMIP_tracer.F90 index c2b189917c..a711437191 100644 --- a/src/tracer/ISOMIP_tracer.F90 +++ b/src/tracer/ISOMIP_tracer.F90 @@ -276,12 +276,11 @@ subroutine ISOMIP_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, G ! h_new(k) = h_old(k) + ea(k) - eb(k-1) + eb(k) - ea(k+1) ! Local variables - real :: mmax real :: b1(SZI_(G)) ! b1 and c1 are variables used by the real :: c1(SZI_(G),SZK_(G)) ! tridiagonal solver. real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: h_work ! Used so that h can be modified - real :: melt(SZI_(G),SZJ_(G)) ! melt water (positive for melting - ! negative for freezing) + real :: melt(SZI_(G),SZJ_(G)) ! melt water (positive for melting, negative for freezing) [Z year-1 ~> m year-1] + real :: mmax ! The global maximum melting rate [Z year-1 ~> m year-1] character(len=256) :: mesg ! The text of an error message integer :: i, j, k, is, ie, js, je, nz, m is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke From 16a48e5c8f9b8b7a5e5e3774577ebf25fcdbc96b Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sun, 22 Mar 2020 09:12:32 -0400 Subject: [PATCH 117/316] Rescaled internal MOM_ice_shelf variables units Enabled the dimensional rescaling of the units of many internal variables in MOM_ice_shelf.F90, and added comments describing the units of other variables. Comments also highlight (but deliberately do not correct) several bugs in the 3-equation boundary property calculation. All answers are bitwise identical. --- src/ice_shelf/MOM_ice_shelf.F90 | 223 ++++++++++++++++---------------- 1 file changed, 114 insertions(+), 109 deletions(-) diff --git a/src/ice_shelf/MOM_ice_shelf.F90 b/src/ice_shelf/MOM_ice_shelf.F90 index 5a7befbea7..45ded4de39 100644 --- a/src/ice_shelf/MOM_ice_shelf.F90 +++ b/src/ice_shelf/MOM_ice_shelf.F90 @@ -90,20 +90,20 @@ module MOM_ice_shelf real :: ustar_bg !< A minimum value for ustar under ice shelves [Z T-1 ~> m s-1]. real :: cdrag !< drag coefficient under ice shelves [nondim]. - real :: g_Earth !< The gravitational acceleration [m s-2] + real :: g_Earth !< The gravitational acceleration [Z T-2 ~> m s-2] real :: Cp !< The heat capacity of sea water [Q degC-1 ~> J kg-1 degC-1]. - real :: Rho0 !< A reference ocean density [kg m-3]. + real :: Rho0 !< A reference ocean density [R ~> kg m-3]. real :: Cp_ice !< The heat capacity of fresh ice [Q degC-1 ~> J kg-1 degC-1]. real :: gamma_t !< The (fixed) turbulent exchange velocity in the - !< 2-equation formulation [m s-1]. + !< 2-equation formulation [Z T-1 ~> m s-1]. real :: Salin_ice !< The salinity of shelf ice [ppt]. real :: Temp_ice !< The core temperature of shelf ice [degC]. - real :: kv_ice !< The viscosity of ice [m2 s-1]. + real :: kv_ice !< The viscosity of ice [Z2 T-1 ~> m2 s-1]. real :: density_ice !< A typical density of ice [R ~> kg m-3]. real :: rho_ice !< Nominal ice density [kg m-2 Z-1 ~> 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 [m2 s-1]. - real :: kd_molec_temp!< The molecular diffusivity of heat [m2 s-1]. + real :: kv_molec !< The molecular kinematic viscosity of sea water [Z2 T-1 ~> m2 s-1]. + real :: kd_molec_salt!< The molecular diffusivity of salt [Z2 T-1 ~> m2 s-1]. + real :: kd_molec_temp!< The molecular diffusivity of heat [Z2 T-1 ~> m2 s-1]. real :: Lat_fusion !< The latent heat of fusion [Q ~> J kg-1]. real :: Gamma_T_3EQ !< Nondimensional heat-transfer coefficient, used in the 3Eq. formulation !< This number should be specified by the user. @@ -153,10 +153,11 @@ module MOM_ice_shelf logical :: find_salt_root !< If true, if true find Sbdry using a quadratic eq. logical :: constant_sea_level !< if true, apply an evaporative, heat and salt !! fluxes. It will avoid large increase in sea level. - real :: cutoff_depth !< depth above which melt is set to zero (>= 0). - real :: lambda1 !< liquidus coeff., Needed if find_salt_root = true - real :: lambda2 !< liquidus coeff., Needed if find_salt_root = true - real :: lambda3 !< liquidus coeff., Needed if find_salt_root = true + real :: cutoff_depth !< Depth above which melt is set to zero (>= 0) [Z ~> m]. + ! The following parameters are needed if find_salt_root = true + real :: lambda1 !< liquidus coeff. The freezing point at 0 pressure and 0 salinity [degC] + real :: lambda2 !< Partial derivative of freezing temperature with salinity [degC ppt-1] + real :: lambda3 !< Partial derivative of freezing temperature with pressure [degC Pa-1] !>@{ Diagnostic handles integer :: id_melt = -1, id_exch_vel_s = -1, id_exch_vel_t = -1, & id_tfreeze = -1, id_tfl_shelf = -1, & @@ -218,8 +219,8 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) p_int !< The pressure at the ice-ocean interface [Pa]. real, dimension(SZI_(CS%grid),SZJ_(CS%grid)) :: & - exch_vel_t, & !< Sub-shelf thermal exchange velocity [m s-1] - exch_vel_s !< Sub-shelf salt exchange velocity [m s-1] + exch_vel_t, & !< Sub-shelf thermal exchange velocity [Z T-1 ~> m s-1] + exch_vel_s !< Sub-shelf salt exchange velocity [Z T-1 ~> m s-1] real, dimension(SZDI_(CS%grid),SZDJ_(CS%grid)) :: & mass_flux !< Total mass flux of freshwater across the ice-ocean interface. [R Z L2 T-1 ~> kg/s] @@ -229,10 +230,10 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) !! This is computed as part of the ISOMIP diagnostics. real, parameter :: VK = 0.40 !< Von Karman's constant - dimensionless real :: ZETA_N = 0.052 !> The fraction of the boundary layer over which the - !! viscosity is linearly increasing. (Was 1/8. Why?) + !! viscosity is linearly increasing [nondim]. (Was 1/8. Why?) real, parameter :: RC = 0.20 ! critical flux Richardson number. - real :: I_ZETA_N !< The inverse of ZETA_N. - real :: LF !< Latent Heat of fusion [J kg-1]. + real :: I_ZETA_N !< The inverse of ZETA_N [nondim]. +!### real :: LF !< Latent Heat of fusion [J kg-1]. real :: I_LF !< The inverse of the latent Heat of fusion [Q-1 ~> kg J-1]. real :: I_VK !< The inverse of VK. real :: PR, SC !< The Prandtl number and Schmidt number [nondim]. @@ -241,33 +242,37 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) real, dimension(SZDI_(CS%grid),SZDJ_(CS%grid)) :: & Sbdry !< Salinities in the ocean at the interface with the ice shelf [ppt]. real :: Sbdry_it - real :: Sbdry1, Sbdry2, S_a, S_b, S_c ! use to find salt roots + real :: Sbdry1, Sbdry2, S_a, S_b, S_c ! Variables used to find salt roots real :: dS_it !< The interface salinity change during an iteration [ppt]. - real :: hBL_neut !< The neutral boundary layer thickness [m]. + real :: hBL_neut !< The neutral boundary layer thickness [Z ~> m]. real :: hBL_neut_h_molec !< The ratio of the neutral boundary layer thickness !! to the molecular boundary layer thickness [nondim]. !### THESE ARE CURRENTLY POSITIVE UPWARD. - real :: wT_flux !< The vertical flux of heat just inside the ocean [degC m s-1]. - real :: wB_flux !< The vertical flux of heat just inside the ocean [m2 s-3]. - real :: dB_dS !< The derivative of buoyancy with salinity [m s-2 ppt-1]. - real :: dB_dT !< The derivative of buoyancy with temperature [m s-2 degC-1]. - real :: I_n_star, n_star_term - real :: absf ! The absolute value of the Coriolis parameter [T-1 ~> s-1] - real :: dIns_dwB !< The partial derivative of I_n_star with wB_flux, in ???. - real :: dT_ustar, dS_ustar - real :: ustar_h ! The friction velocity in the water below the ice shelf [Z T-1 ~> m s-1] - real :: Gam_turb + real :: wT_flux !< The vertical flux of heat just inside the ocean [degC Z T-1 ~> degC m s-1]. + real :: wB_flux !< The vertical flux of buoyancy just inside the ocean [Z2 T-3 ~> m2 s-3]. + real :: dB_dS !< The derivative of buoyancy with salinity [Z T-2 ppt-1 ~> m s-2 ppt-1]. + real :: dB_dT !< The derivative of buoyancy with temperature [Z T-2 degC-1 ~> m s-2 degC-1]. + real :: I_n_star ! [nondim] + real :: n_star_term ! A term in the expression for nstar [T3 Z-2 ~> s3 m-2] + real :: absf ! The absolute value of the Coriolis parameter [T-1 ~> s-1] + real :: dIns_dwB !< The partial derivative of I_n_star with wB_flux, in [T3 Z-2 ~> s3 m-2] + real :: dT_ustar ! The difference between the ocean boundary layer temperature and the freezing + ! freezing point times the friction velocity [degC Z T-1 ~> degC m s-1] + real :: dS_ustar ! The difference between the ocean boundary layer salinity and the salinity + ! at the ice-ocean interface the friction velocity [ppt Z T-1 ~> ppt m s-1] + real :: ustar_h ! The friction velocity in the water below the ice shelf [Z T-1 ~> m s-1] + real :: Gam_turb ! [nondim] real :: Gam_mol_t, Gam_mol_s real :: RhoCp ! A typical ocean density times the heat capacity of water [Q R ~> J m-3] -!### real :: I_RhoLF ! The inverse of the ocean density times the latent heat of fusion [Q-1 R-1 ~> m3 J-1] real :: ln_neut - real :: mass_exch + real :: mass_exch ! A mass exchange rate [R Z T-1 ~> kg m-2 s-1] real :: Sb_min, Sb_max real :: dS_min, dS_max ! Variables used in iterating for wB_flux. - real :: wB_flux_new, DwB, dDwB_dwB_in - real :: I_Gam_T, I_Gam_S, dG_dwB, iDens - real :: u_at_h, v_at_h, Isqrt2 + real :: wB_flux_new, dDwB_dwB_in + real :: I_Gam_T, I_Gam_S, iDens + real :: dG_dwB ! The derivative of Gam_turb with wB [T3 Z-2 ~> s3 m-2] + real :: Isqrt2 logical :: Sb_min_set, Sb_max_set 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 @@ -288,13 +293,12 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) ! 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 = US%Q_to_J_kg*CS%Lat_fusion -!### I_RhoLF = 1.0/(CS%Rho0*US%Q_to_J_kg*CS%Lat_fusion) +!### LF = US%Q_to_J_kg*CS%Lat_fusion I_LF = 1.0 / CS%Lat_fusion SC = CS%kv_molec/CS%kd_molec_salt PR = CS%kv_molec/CS%kd_molec_temp I_VK = 1.0/VK - RhoCp = US%kg_m3_to_R*CS%Rho0 * CS%Cp + RhoCp = CS%Rho0 * CS%Cp Isqrt2 = 1.0/sqrt(2.0) !first calculate molecular component @@ -336,7 +340,7 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) 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 * ISS%mass_shelf(i,j) ; enddo + do i=is,ie ; p_int(i) = US%Z_to_m*US%s_to_T**2*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, & @@ -360,16 +364,13 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) ! Iteratively determine a self-consistent set of fluxes, with the ocean ! salinity just below the ice-shelf as the variable that is being ! iterated for. - ! ### SHOULD I SET USTAR_SHELF YET? - - u_at_h = state%u(i,j) - v_at_h = state%v(i,j) + ! ### SHOULD USTAR_SHELF BE SET YET? !### I think that CS%utide**1 should be CS%utide**2 ! Also I think that if taux_shelf and tauy_shelf have been calculated by the ! ocean stress calculation, they should be used here or later to set ustar_shelf. - RWH fluxes%ustar_shelf(i,j) = MAX(CS%ustar_bg, US%m_to_Z*US%T_to_s * & - sqrt(CS%cdrag*((u_at_h**2 + v_at_h**2) + CS%utide(i,j)**1))) + sqrt(CS%cdrag*((state%u(i,j)**2 + state%v(i,j)**2) + CS%utide(i,j)**1))) ustar_h = fluxes%ustar_shelf(i,j) @@ -377,7 +378,7 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) ! if (allocated(state%taux_shelf) .and. allocated(state%tauy_shelf)) then ! ! These arrays are supposed to be stress components at C-grid points, which is ! ! inconsistent with what is coded up here. - ! state%taux_shelf(i,j) = US%Z_to_m**2*US%s_to_T**2*ustar_h**2 * CS%Rho0*Isqrt2 + ! state%taux_shelf(i,j) = US%RZ_T_to_kg_m2s*US%Z_to_m*US%s_to_T * ustar_h**2 * CS%Rho0*Isqrt2 ! state%tauy_shelf(i,j) = state%taux_shelf(i,j) ! endif @@ -385,9 +386,9 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) ! reported ocean mixed layer thickness and the neutral Ekman depth. absf = 0.25*((abs(G%CoriolisBu(I,J)) + abs(G%CoriolisBu(I-1,J-1))) + & (abs(G%CoriolisBu(I,J-1)) + abs(G%CoriolisBu(I-1,J)))) - if (absf*US%Z_to_m*state%Hml(i,j) <= VK*ustar_h) then ; hBL_neut = state%Hml(i,j) - else ; hBL_neut = US%Z_to_m*(VK*ustar_h) / absf ; endif - hBL_neut_h_molec = ZETA_N * ((hBL_neut * US%Z_to_m*US%s_to_T*ustar_h) / (5.0 * CS%Kv_molec)) + if (absf*US%m_to_Z*state%Hml(i,j) <= VK*ustar_h) then ; hBL_neut = US%m_to_Z*state%Hml(i,j) + else ; hBL_neut = (VK*ustar_h) / absf ; endif + hBL_neut_h_molec = ZETA_N * ((hBL_neut * ustar_h) / (5.0 * CS%kv_molec)) ! Determine the mixed layer buoyancy flux, wB_flux. dB_dS = (CS%g_Earth / Rhoml(i)) * dR0_dS(i) @@ -397,17 +398,23 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) if (CS%find_salt_root) then ! read liquidus parameters - S_a = CS%lambda1 * CS%Gamma_T_3EQ * US%Q_to_J_kg*CS%Cp -! S_b = -CS%Gamma_T_3EQ*(CS%lambda2-CS%lambda3*p_int(i)-state%sst(i,j)) & -! -LF*CS%Gamma_T_3EQ/35.0 - - S_b = CS%Gamma_T_3EQ*US%Q_to_J_kg*CS%Cp*(CS%lambda2+CS%lambda3*p_int(i)- & - state%sst(i,j))-LF*CS%Gamma_T_3EQ/35.0 - S_c = LF*(CS%Gamma_T_3EQ/35.0)*state%sss(i,j) + !### This should be CS%lamda2! + S_a = CS%lambda1 * CS%Gamma_T_3EQ * CS%Cp + ! The value of 35.0 here should be a parameter? + !### This should be (CS%lambda1 + CS%lambda3*p_int(i) - state%sst(i,j)) + S_b = CS%Gamma_T_3EQ*CS%Cp*(CS%lambda2 + CS%lambda3*p_int(i)- state%sst(i,j)) - & + CS%Lat_fusion * CS%Gamma_T_3EQ/35.0 + S_c = CS%Lat_fusion * (CS%Gamma_T_3EQ/35.0) * state%sss(i,j) !### Depending on the sign of S_b, one of these will be inaccurate! - Sbdry1 = (-S_b + SQRT(S_b*S_b-4*S_a*S_c))/(2*S_a) - Sbdry2 = (-S_b - SQRT(S_b*S_b-4*S_a*S_c))/(2*S_a) + ! if (S_b >= 0.0) then + Sbdry1 = (-S_b + SQRT(S_b*S_b - 4*S_a*S_c)) / (2*S_a) + ! Sbdry1 = 2*S_c / (S_b + SQRT(S_b*S_b - 4*S_a*S_c)) + Sbdry2 = (-S_b - SQRT(S_b*S_b - 4*S_a*S_c)) / (2*S_a) + ! else + ! Sbdry1 = (-S_b + SQRT(S_b*S_b - 4.*S_a*S_c)) / (2.*S_a) + ! Sbdry2 = -2.*S_c / (-S_b + SQRT(S_b*S_b - 4.*S_a*S_c)) + ! endif Sbdry(i,j) = MAX(Sbdry1, Sbdry2) ! Safety check if (Sbdry(i,j) < 0.) then @@ -427,8 +434,8 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) ! Determine the potential temperature at the ice-ocean interface. call calculate_TFreeze(Sbdry(i,j), p_int(i), ISS%tfreeze(i,j), CS%eqn_of_state) - dT_ustar = (state%sst(i,j) - ISS%tfreeze(i,j)) * US%Z_to_m*US%s_to_T*ustar_h - dS_ustar = (state%sss(i,j) - Sbdry(i,j)) * US%Z_to_m*US%s_to_T*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 ! on the turbulence. Following H & J '99, this limit also applies @@ -445,12 +452,12 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) endif wT_flux = dT_ustar * I_Gam_T - wB_flux = dB_dS * (dS_ustar * I_Gam_S) + dB_dT * wT_flux + wB_flux = dB_dS * (dS_ustar * I_Gam_S) + US%Z_to_m*US%s_to_T**2*dB_dT * wT_flux if (wB_flux > 0.0) then ! The buoyancy flux is stabilizing and will reduce the tubulent ! fluxes, and iteration is required. - n_star_term = (ZETA_N/RC) * (hBL_neut * VK) / (US%Z_to_m*US%s_to_T*ustar_h)**3 + n_star_term = (ZETA_N/RC) * (hBL_neut * VK) / (ustar_h)**3 do it3 = 1,30 ! n_star <= 1.0 is the ratio of working boundary layer thickness ! to the neutral thickness. @@ -481,8 +488,7 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) wT_flux = dT_ustar * I_Gam_T wB_flux_new = dB_dS * (dS_ustar * I_Gam_S) + dB_dT * wT_flux - ! Find the root where dwB = 0.0 - DwB = wB_flux_new - wB_flux + ! Find the root where wB_flux_new = wB_flux. if (abs(wB_flux_new - wB_flux) < & 1e-4*(abs(wB_flux_new) + abs(wB_flux))) exit @@ -490,18 +496,18 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) dB_dT * (dT_ustar * I_Gam_T**2)) - 1.0 ! This is Newton's method without any bounds. ! ### SHOULD BOUNDS BE NEEDED? - wB_flux_new = wB_flux - DwB / dDwB_dwB_in + wB_flux_new = wB_flux - (wB_flux_new - wB_flux) / dDwB_dwB_in enddo !it3 endif - ISS%tflux_ocn(i,j) = US%R_to_kg_m3*US%Q_to_J_kg*RhoCp * wT_flux - exch_vel_t(i,j) = US%Z_to_m*US%s_to_T*ustar_h * I_Gam_T - exch_vel_s(i,j) = US%Z_to_m*US%s_to_T*ustar_h * I_Gam_S + ISS%tflux_ocn(i,j) = US%R_to_kg_m3*US%Q_to_J_kg*RhoCp * US%Z_to_m*US%s_to_T*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. !vertical adv/diff as in H+J 1999, eqns (26) & approx from (31). - ! Q_ice = rho_ice * CS%CP_Ice * K_ice * dT/dz (at interface) + ! Q_ice = rho_ice * CS%Cp_ice * K_ice * dT/dz (at interface) !vertical adv/diff as in H+J 199, eqs (31) & (26)... ! 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. @@ -517,19 +523,19 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) else ! With melting, from H&J 1999, eqs (31) & (26)... - ! Q_ice ~= cp_ice * (CS%Temp_Ice-T_freeze) * lprec + ! 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) = US%kg_m2s_to_RZ_T * ISS%tflux_ocn(i,j) / & - (LF + CS%CP_Ice * (ISS%tfreeze(i,j) - CS%Temp_Ice)) + ! lprec = (ISS%tflux_ocn(i,j)) / (CS%Lat_fusion + Cp_ice * (T_freeze-CS%Temp_Ice)) + ISS%water_flux(i,j) = US%W_m2_to_QRZ_T * ISS%tflux_ocn(i,j) / & + (CS%Lat_fusion + CS%Cp_ice * (ISS%tfreeze(i,j) - CS%Temp_Ice)) - ISS%tflux_shelf(i,j) = ISS%tflux_ocn(i,j) - LF*US%RZ_T_to_kg_m2s*ISS%water_flux(i,j) + ISS%tflux_shelf(i,j) = ISS%tflux_ocn(i,j) - CS%Lat_fusion*US%QRZ_T_to_W_m2*ISS%water_flux(i,j) endif endif !other options: dTi/dz linear through shelf ! 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 + ! ISS%tflux_shelf(i,j) = - Rho_Ice * US%Q_to_J_kg*CS%Cp_ice * KTI * dTi_dz if (CS%find_salt_root) then @@ -537,8 +543,8 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) else mass_exch = exch_vel_s(i,j) * CS%Rho0 - Sbdry_it = (state%sss(i,j) * mass_exch + CS%Salin_ice * US%RZ_T_to_kg_m2s*ISS%water_flux(i,j)) / & - (mass_exch + US%RZ_T_to_kg_m2s*ISS%water_flux(i,j)) + Sbdry_it = (state%sss(i,j) * mass_exch + CS%Salin_ice * 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 @@ -576,7 +582,7 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) call calculate_TFreeze(state%sss(i,j), p_int(i), ISS%tfreeze(i,j), CS%eqn_of_state) exch_vel_t(i,j) = CS%gamma_t - ISS%tflux_ocn(i,j) = US%R_to_kg_m3*US%Q_to_J_kg*RhoCp * exch_vel_t(i,j) * (state%sst(i,j) - ISS%tfreeze(i,j)) + ISS%tflux_ocn(i,j) = US%QRZ_T_to_W_m2*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) = US%W_m2_to_QRZ_T * I_LF * ISS%tflux_ocn(i,j) Sbdry(i,j) = 0.0 @@ -603,17 +609,14 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) (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 + ! 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 ((ISS%mass_shelf(i,j)) < US%RZ_to_kg_m2*CS%Rho0*CS%cutoff_depth) 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) = (US%RZ_T_to_kg_m2s*ISS%water_flux(i,j) * Sbdry(i,j)) / & - (CS%Rho0 * exch_vel_s(i,j)) + 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 @@ -802,7 +805,8 @@ subroutine add_shelf_forces(G, US, CS, forces, do_shelf_area) !### 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)) + press_ice = (ISS%area_shelf_h(i,j) * G%IareaT(i,j)) * & + US%Z_to_m*US%s_to_T**2*(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 @@ -817,7 +821,7 @@ subroutine add_shelf_forces(G, US, CS, forces, do_shelf_area) ! 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 / (US%R_to_kg_m3*CS%density_ice) + kv_rho_ice = US%Z2_T_to_m2_s*CS%kv_ice / (US%R_to_kg_m3*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) + & @@ -854,7 +858,8 @@ subroutine add_shelf_pressure(G, US, CS, fluxes) call MOM_error(FATAL,"add_shelf_pressure: Incompatible ocean and ice shelf grids.") 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)) + press_ice = (CS%ISS%area_shelf_h(i,j) * G%IareaT(i,j)) * & + US%Z_to_m*US%s_to_T**2*(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 @@ -876,7 +881,8 @@ subroutine add_shelf_flux(G, US, CS, state, fluxes) 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 [m3 kg-1]. + real :: Irho0 !< The inverse of the mean density times unit conversion factors that + !! arise because state uses MKS units [Z2 m s2 kg-1 T-2 ~> m3 kg-1]. real :: frac_area !< The fractional area covered by the ice shelf [nondim]. real :: shelf_mass0 !< Total ice shelf mass at previous time (Time-dt). real :: shelf_mass1 !< Total ice shelf mass at current time (Time). @@ -933,7 +939,7 @@ subroutine add_shelf_flux(G, US, CS, state, fluxes) call pass_vector(state%taux_shelf, state%tauy_shelf, G%domain, TO_ALL, CGRID_NE) ! 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 +! Irho0 = US%m_to_Z*US%T_to_s*US%kg_m2s_to_RZ_T / 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 @@ -948,7 +954,7 @@ subroutine add_shelf_flux(G, US, CS, state, fluxes) ! 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, US%m_to_Z*US%T_to_s*sqrt(Irho0 * sqrt(taux2 + tauy2))) + ! fluxes%ustar(i,j) = MAX(CS%ustar_bg, sqrt(Irho0 * sqrt(taux2 + tauy2))) ! endif ; enddo ; enddo endif @@ -1061,11 +1067,10 @@ subroutine add_shelf_flux(G, US, CS, state, 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 * US%R_to_kg_m3*CS%density_ice/1000. ! evap is negative - ! Rescale fluxes%vprec to the proper units. - fluxes%vprec(i,j) = US%kg_m2s_to_RZ_T * fluxes%vprec(i,j) - fluxes%sens(i,j) = fluxes%vprec(i,j) * US%J_kg_to_Q*US%Q_to_J_kg*CS%Cp * CS%T0 ! [ Q R Z T-1 ~> W /m^2 ] - fluxes%salt_flux(i,j) = fluxes%vprec(i,j) * CS%S0*1.0e-3 ! kg (salt)/(m^2 s) + ! evap is negative, and vprec has units of [R Z T-1 ~> kg m-2 s-1] + fluxes%vprec(i,j) = -US%kg_m2s_to_RZ_T* mean_melt_flux * CS%density_ice / (1000.0*US%kg_m3_to_R) + fluxes%sens(i,j) = fluxes%vprec(i,j) * CS%Cp * CS%T0 ! [ Q R Z T-1 ~> W /m^2 ] + fluxes%salt_flux(i,j) = fluxes%vprec(i,j) * CS%S0*1.0e-3 ! [kgSalt/kg R Z T-1 ~> kgSalt m-2 s-1] endif enddo ; enddo @@ -1173,6 +1178,7 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl isd = G%isd ; jsd = G%jsd ; ied = G%ied ; jed = G%jed Isdq = G%IsdB ; Iedq = G%IedB ; Jsdq = G%JsdB ; Jedq = G%JedB + !### This should be a run-time parameter that is read in consistently with MOM6 and SIS2. CS%Lat_fusion = 3.34e5*US%J_kg_to_Q CS%override_shelf_movement = .false. ; CS%active_shelf_dynamics = .false. @@ -1212,7 +1218,7 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl "(no conduction).", default=.false.) call get_param(param_file, mdl, "MELTING_CUTOFF_DEPTH", CS%cutoff_depth, & "Depth above which the melt is set to zero (it must be >= 0) "//& - "Default value won't affect the solution.", default=0.0) + "Default value won't affect the solution.", default=0.0, scale=US%m_to_Z) !###, units="m" if (CS%cutoff_depth < 0.) & call MOM_error(WARNING,"Initialize_ice_shelf: MELTING_CUTOFF_DEPTH must be >= 0.") @@ -1250,29 +1256,28 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl "is computed from a quadratic equation. Otherwise, the previous "//& "interactive method to estimate Sbdry is used.", default=.false.) if (CS%find_salt_root) then ! read liquidus coeffs. - call get_param(param_file, mdl, "TFREEZE_S0_P0",CS%lambda1, & + call get_param(param_file, mdl, "TFREEZE_S0_P0", CS%lambda1, & "this is the freezing potential temperature at "//& "S=0, P=0.", units="degC", default=0.0, do_not_log=.true.) - call get_param(param_file, mdl, "DTFREEZE_DS",CS%lambda1, & + call get_param(param_file, mdl, "DTFREEZE_DS", CS%lambda1, & !### This should be CS%lambda2! "this is the derivative of the freezing potential "//& "temperature with salinity.", & units="degC psu-1", default=-0.054, do_not_log=.true.) - call get_param(param_file, mdl, "DTFREEZE_DP",CS%lambda3, & + call get_param(param_file, mdl, "DTFREEZE_DP", CS%lambda3, & "this is the derivative of the freezing potential "//& "temperature with pressure.", & units="degC Pa-1", default=0.0, do_not_log=.true.) - endif if (.not.CS%threeeq) & call get_param(param_file, mdl, "SHELF_2EQ_GAMMA_T", CS%gamma_t, & "If SHELF_THREE_EQN is false, this the fixed turbulent "//& "exchange velocity at the ice-ocean interface.", & - units="m s-1", fail_if_missing=.true.) + units="m s-1", scale=US%m_to_Z*US%T_to_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) + units="m s-2", default = 9.80, scale=US%m_to_Z*US%T_to_s**2) call get_param(param_file, mdl, "C_P", CS%Cp, & "The heat capacity of sea water.", units="J kg-1 K-1", scale=US%J_kg_to_Q, & fail_if_missing=.true.) @@ -1281,7 +1286,7 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl "calculate accelerations and the mass for conservation "//& "properties, or with BOUSSINSEQ false to convert some "//& "parameters from vertical units of m to kg m-2.", & - units="kg m-3", default=1035.0) !### MAKE THIS A SEPARATE PARAMETER. + units="kg m-3", default=1035.0, scale=US%R_to_kg_m3) !### MAKE THIS A SEPARATE PARAMETER. call get_param(param_file, mdl, "C_P_ICE", CS%Cp_ice, & "The heat capacity of ice.", units="J kg-1 K-1", scale=US%J_kg_to_Q, & default=2.10e3) @@ -1291,10 +1296,10 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl "fluxes.", units="none", default=1.0) call get_param(param_file, mdl, "KV_ICE", CS%kv_ice, & - "The viscosity of the ice.", units="m2 s-1", default=1.0e10) + "The viscosity of the ice.", units="m2 s-1", default=1.0e10, scale=US%m2_s_to_Z2_T) call get_param(param_file, mdl, "KV_MOLECULAR", CS%kv_molec, & "The molecular kinimatic viscosity of sea water at the "//& - "freezing temperature.", units="m2 s-1", default=1.95e-6) + "freezing temperature.", units="m2 s-1", default=1.95e-6, scale=US%m2_s_to_Z2_T) call get_param(param_file, mdl, "ICE_SHELF_SALINITY", CS%Salin_ice, & "The salinity of the ice inside the ice shelf.", units="psu", & default=0.0) @@ -1303,10 +1308,10 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl units = "degC", default=-15.0) call get_param(param_file, mdl, "KD_SALT_MOLECULAR", CS%kd_molec_salt, & "The molecular diffusivity of salt in sea water at the "//& - "freezing point.", units="m2 s-1", default=8.02e-10) + "freezing point.", units="m2 s-1", default=8.02e-10, scale=US%m2_s_to_Z2_T) call get_param(param_file, mdl, "KD_TEMP_MOLECULAR", CS%kd_molec_temp, & "The molecular diffusivity of heat in sea water at the "//& - "freezing point.", units="m2 s-1", default=1.41e-7) + "freezing point.", units="m2 s-1", default=1.41e-7, scale=US%m2_s_to_Z2_T) 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.) @@ -1591,9 +1596,9 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl CS%id_v_ml = register_diag_field('ocean_model', 'v_ml', CS%diag%axesCv1, CS%Time, & 'Northward vel. in the boundary layer (used to compute ustar)', 'm s-1') CS%id_exch_vel_s = register_diag_field('ocean_model', 'exch_vel_s', CS%diag%axesT1, CS%Time, & - 'Sub-shelf salinity exchange velocity', 'm s-1') + 'Sub-shelf salinity exchange velocity', 'm s-1', conversion=US%Z_to_m*US%s_to_T) CS%id_exch_vel_t = register_diag_field('ocean_model', 'exch_vel_t', CS%diag%axesT1, CS%Time, & - 'Sub-shelf thermal exchange velocity', 'm s-1') + 'Sub-shelf thermal exchange velocity', 'm s-1' , conversion=US%Z_to_m*US%s_to_T) CS%id_tfreeze = register_diag_field('ocean_model', 'tfreeze', CS%diag%axesT1, CS%Time, & 'In Situ Freezing point at ice shelf interface', 'degC') CS%id_tfl_shelf = register_diag_field('ocean_model', 'tflux_shelf', CS%diag%axesT1, CS%Time, & From e1fcb3bc8c13a7ef58cb4fa6a542b088dd89dcd5 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sun, 22 Mar 2020 11:36:01 -0400 Subject: [PATCH 118/316] Changed the sign of ISS%tflux_ocn and rescaled it Changed the sign of ISS%tflux_ocn and ISS%tflux_shelf to comply with MOM6 sign conventions, and dimensionally rescaled these variables to [Q R Z T-1]. MOM_ice_shelf.F90, and added comments describing the units of other variables. All answers are bitwise identical. --- src/ice_shelf/MOM_ice_shelf.F90 | 44 +++++++++++++-------------- src/ice_shelf/MOM_ice_shelf_state.F90 | 10 +++--- 2 files changed, 26 insertions(+), 28 deletions(-) diff --git a/src/ice_shelf/MOM_ice_shelf.F90 b/src/ice_shelf/MOM_ice_shelf.F90 index 45ded4de39..da7015d7c3 100644 --- a/src/ice_shelf/MOM_ice_shelf.F90 +++ b/src/ice_shelf/MOM_ice_shelf.F90 @@ -248,8 +248,8 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) real :: hBL_neut_h_molec !< The ratio of the neutral boundary layer thickness !! to the molecular boundary layer thickness [nondim]. !### THESE ARE CURRENTLY POSITIVE UPWARD. - real :: wT_flux !< The vertical flux of heat just inside the ocean [degC Z T-1 ~> degC m s-1]. - real :: wB_flux !< The vertical flux of buoyancy just inside the ocean [Z2 T-3 ~> m2 s-3]. + real :: wT_flux !< The upward vertical flux of heat just inside the ocean [degC Z T-1 ~> degC m s-1]. + real :: wB_flux !< The upward vertical flux of buoyancy just inside the ocean [Z2 T-3 ~> m2 s-3]. real :: dB_dS !< The derivative of buoyancy with salinity [Z T-2 ppt-1 ~> m s-2 ppt-1]. real :: dB_dT !< The derivative of buoyancy with temperature [Z T-2 degC-1 ~> m s-2 degC-1]. real :: I_n_star ! [nondim] @@ -313,8 +313,7 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) ! reasons, it is better to set them to zero again. 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 + 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. haline_driving(:,:) = 0.0 Sbdry(:,:) = state%sss(:,:) @@ -500,42 +499,41 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) enddo !it3 endif - ISS%tflux_ocn(i,j) = US%R_to_kg_m3*US%Q_to_J_kg*RhoCp * US%Z_to_m*US%s_to_T*wT_flux + 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. !vertical adv/diff as in H+J 1999, eqns (26) & approx from (31). - ! Q_ice = rho_ice * CS%Cp_ice * K_ice * dT/dz (at interface) + ! Q_ice = density_ice * CS%Cp_ice * K_ice * dT/dz (at interface) !vertical adv/diff as in H+J 199, eqs (31) & (26)... - ! dT/dz ~= min( (lprec/(rho_ice*K_ice))*(CS%Temp_Ice-T_freeze) , 0.0 ) + ! dT/dz ~= min( (lprec/(density_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 (ISS%tflux_ocn(i,j) <= 0.0) then ! Freezing occurs, so zero ice heat flux. - ISS%water_flux(i,j) = US%W_m2_to_QRZ_T * I_LF * ISS%tflux_ocn(i,j) + if (ISS%tflux_ocn(i,j) >= 0.0) then ! Freezing occurs due to downward ocean heat flux, 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 ISS%tflux_shelf(i,j) = 0.0 - ISS%water_flux(i,j) = US%W_m2_to_QRZ_T * I_LF * (- ISS%tflux_shelf(i,j) + ISS%tflux_ocn(i,j)) + 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 + ISS%tflux_ocn(i,j) - ! lprec = (ISS%tflux_ocn(i,j)) / (CS%Lat_fusion + Cp_ice * (T_freeze-CS%Temp_Ice)) - ISS%water_flux(i,j) = US%W_m2_to_QRZ_T * ISS%tflux_ocn(i,j) / & - (CS%Lat_fusion + CS%Cp_ice * (ISS%tfreeze(i,j) - CS%Temp_Ice)) + ! RhoLF*lprec = Q_ice - ISS%tflux_ocn(i,j) + ! lprec = -(ISS%tflux_ocn(i,j)) / (CS%Lat_fusion + Cp_ice * (T_freeze-CS%Temp_Ice)) + ISS%water_flux(i,j) = -ISS%tflux_ocn(i,j) / (CS%Lat_fusion + CS%Cp_ice * (ISS%tfreeze(i,j) - CS%Temp_Ice)) - ISS%tflux_shelf(i,j) = ISS%tflux_ocn(i,j) - CS%Lat_fusion*US%QRZ_T_to_W_m2*ISS%water_flux(i,j) + ISS%tflux_shelf(i,j) = ISS%tflux_ocn(i,j) + CS%Lat_fusion*ISS%water_flux(i,j) endif endif - !other options: dTi/dz linear through shelf - ! dTi_dz = (CS%Temp_Ice - ISS%tfreeze(i,j))/G%draft(i,j) - ! ISS%tflux_shelf(i,j) = - Rho_Ice * US%Q_to_J_kg*CS%Cp_ice * KTI * dTi_dz + !other options: dTi/dz linear through shelf, with draft in [Z ~> m], KTI in [Z2 T-1 ~> m2 s-1] + ! dTi_dz = (CS%Temp_Ice - ISS%tfreeze(i,j)) / draft(i,j) + ! ISS%tflux_shelf(i,j) = Rho_Ice * CS%Cp_ice * KTI * dTi_dz if (CS%find_salt_root) then @@ -582,9 +580,9 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) call calculate_TFreeze(state%sss(i,j), p_int(i), ISS%tfreeze(i,j), CS%eqn_of_state) exch_vel_t(i,j) = CS%gamma_t - ISS%tflux_ocn(i,j) = US%QRZ_T_to_W_m2*RhoCp * exch_vel_t(i,j) * (state%sst(i,j) - ISS%tfreeze(i,j)) + ISS%tflux_ocn(i,j) = RhoCp * exch_vel_t(i,j) * (ISS%tfreeze(i,j) - state%sst(i,j)) ISS%tflux_shelf(i,j) = 0.0 - ISS%water_flux(i,j) = US%W_m2_to_QRZ_T * I_LF * ISS%tflux_ocn(i,j) + ISS%water_flux(i,j) = -I_LF * ISS%tflux_ocn(i,j) Sbdry(i,j) = 0.0 endif else !not shelf @@ -985,7 +983,7 @@ subroutine add_shelf_flux(G, US, CS, state, fluxes) endif if (associated(fluxes%sens)) & - fluxes%sens(i,j) = -frac_area*ISS%tflux_ocn(i,j)*US%W_m2_to_QRZ_T*CS%flux_factor + 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 @@ -1068,7 +1066,7 @@ subroutine add_shelf_flux(G, US, CS, state, fluxes) ! Note the following is hard coded for ISOMIP if (G%geoLonT(i,j) >= 790.0 .AND. G%geoLonT(i,j) <= 800.0) then ! evap is negative, and vprec has units of [R Z T-1 ~> kg m-2 s-1] - fluxes%vprec(i,j) = -US%kg_m2s_to_RZ_T* mean_melt_flux * CS%density_ice / (1000.0*US%kg_m3_to_R) + fluxes%vprec(i,j) = -US%kg_m2s_to_RZ_T*mean_melt_flux * CS%density_ice / (1000.0*US%kg_m3_to_R) fluxes%sens(i,j) = fluxes%vprec(i,j) * CS%Cp * CS%T0 ! [ Q R Z T-1 ~> W /m^2 ] fluxes%salt_flux(i,j) = fluxes%vprec(i,j) * CS%S0*1.0e-3 ! [kgSalt/kg R Z T-1 ~> kgSalt m-2 s-1] endif @@ -1602,7 +1600,7 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl CS%id_tfreeze = register_diag_field('ocean_model', 'tfreeze', CS%diag%axesT1, CS%Time, & 'In Situ Freezing point at ice shelf interface', 'degC') CS%id_tfl_shelf = register_diag_field('ocean_model', 'tflux_shelf', CS%diag%axesT1, CS%Time, & - 'Heat conduction into ice shelf', 'W m-2') + 'Heat conduction into ice shelf', 'W m-2', conversion=-US%QRZ_T_to_W_m2) CS%id_ustar_shelf = register_diag_field('ocean_model', 'ustar_shelf', CS%diag%axesT1, CS%Time, & 'Fric vel under shelf', 'm/s', conversion=US%Z_to_m*US%s_to_T) if (CS%active_shelf_dynamics) then diff --git a/src/ice_shelf/MOM_ice_shelf_state.F90 b/src/ice_shelf/MOM_ice_shelf_state.F90 index ac34817482..98b5d01939 100644 --- a/src/ice_shelf/MOM_ice_shelf_state.F90 +++ b/src/ice_shelf/MOM_ice_shelf_state.F90 @@ -37,14 +37,14 @@ module MOM_ice_shelf_state !! 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 [m-2]. + tflux_ocn => NULL(), & !< The downward sensible ocean heat flux at the + !! ocean-ice interface [Q R Z T-1 ~> W m-2]. salt_flux => NULL(), & !< The downward salt flux at the ocean-ice - !! interface [kg m-2 s-1]. + !! interface [kgSalt kgWater-1 R Z T-1 ~> kgSalt m-2 s-1]. water_flux => NULL(), & !< The net downward liquid water flux at the !! ocean-ice interface [R Z T-1 ~> kg m-2 s-1]. - tflux_shelf => NULL(), & !< The UPWARD diffusive heat flux in the ice - !! shelf at the ice-ocean interface [W m-2]. + tflux_shelf => NULL(), & !< The downward diffusive heat flux in the ice + !! shelf at the ice-ocean interface [Q R Z T-1 ~> W m-2]. tfreeze => NULL() !< The freezing point potential temperature !! an the ice-ocean interface [degC]. From 27bffdbf510a76c01c7c9b76363bd522158eefd6 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sun, 22 Mar 2020 15:04:38 -0400 Subject: [PATCH 119/316] +Rescaled ISS%shelf_mass to [R Z] Rescaled the viarable ISS%shelf_mass to [R Z} for dimensional consistency testing and code simplification. This also required the addition of a new scaling factor to the ice_shelf restart files. All answers are bitwise identical. --- src/ice_shelf/MOM_ice_shelf.F90 | 92 ++++++++++++++---------- src/ice_shelf/MOM_ice_shelf_dynamics.F90 | 2 +- src/ice_shelf/MOM_ice_shelf_state.F90 | 4 +- src/ice_shelf/user_shelf_init.F90 | 9 ++- 4 files changed, 62 insertions(+), 45 deletions(-) diff --git a/src/ice_shelf/MOM_ice_shelf.F90 b/src/ice_shelf/MOM_ice_shelf.F90 index da7015d7c3..62d00e283b 100644 --- a/src/ice_shelf/MOM_ice_shelf.F90 +++ b/src/ice_shelf/MOM_ice_shelf.F90 @@ -100,7 +100,6 @@ module MOM_ice_shelf real :: Temp_ice !< The core temperature of shelf ice [degC]. real :: kv_ice !< The viscosity of ice [Z2 T-1 ~> m2 s-1]. real :: density_ice !< A typical density of ice [R ~> kg m-3]. - real :: rho_ice !< Nominal ice density [kg m-2 Z-1 ~> kg m-3]. real :: kv_molec !< The molecular kinematic viscosity of sea water [Z2 T-1 ~> m2 s-1]. real :: kd_molec_salt!< The molecular diffusivity of salt [Z2 T-1 ~> m2 s-1]. real :: kd_molec_temp!< The molecular diffusivity of heat [Z2 T-1 ~> m2 s-1]. @@ -233,7 +232,6 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) !! viscosity is linearly increasing [nondim]. (Was 1/8. Why?) real, parameter :: RC = 0.20 ! critical flux Richardson number. real :: I_ZETA_N !< The inverse of ZETA_N [nondim]. -!### real :: LF !< Latent Heat of fusion [J kg-1]. real :: I_LF !< The inverse of the latent Heat of fusion [Q-1 ~> kg J-1]. real :: I_VK !< The inverse of VK. real :: PR, SC !< The Prandtl number and Schmidt number [nondim]. @@ -293,7 +291,6 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) ! 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 = US%Q_to_J_kg*CS%Lat_fusion I_LF = 1.0 / CS%Lat_fusion SC = CS%kv_molec/CS%kd_molec_salt PR = CS%kv_molec/CS%kd_molec_temp @@ -324,7 +321,7 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) 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) + if (CS%mass_from_file) call update_shelf_mass(G, US, CS, ISS, Time) endif if (CS%debug) then @@ -339,7 +336,7 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) 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) = US%Z_to_m*US%s_to_T**2*CS%g_Earth * ISS%mass_shelf(i,j) ; enddo + do i=is,ie ; p_int(i) = US%RZ_to_kg_m2*US%Z_to_m*US%s_to_T**2*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, & @@ -451,7 +448,7 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) endif wT_flux = dT_ustar * I_Gam_T - wB_flux = dB_dS * (dS_ustar * I_Gam_S) + US%Z_to_m*US%s_to_T**2*dB_dT * wT_flux + wB_flux = dB_dS * (dS_ustar * I_Gam_S) + dB_dT * wT_flux if (wB_flux > 0.0) then ! The buoyancy flux is stabilizing and will reduce the tubulent @@ -511,7 +508,8 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) ! dT/dz ~= min( (lprec/(density_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 (ISS%tflux_ocn(i,j) >= 0.0) then ! Freezing occurs due to downward ocean heat flux, so zero ice heat flux. + if (ISS%tflux_ocn(i,j) >= 0.0) then + ! Freezing occurs due to downward ocean heat flux, so zero iout ce heat flux. ISS%water_flux(i,j) = -I_LF * ISS%tflux_ocn(i,j) ISS%tflux_shelf(i,j) = 0.0 else @@ -525,7 +523,8 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) ! 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)) / (CS%Lat_fusion + Cp_ice * (T_freeze-CS%Temp_Ice)) - ISS%water_flux(i,j) = -ISS%tflux_ocn(i,j) / (CS%Lat_fusion + CS%Cp_ice * (ISS%tfreeze(i,j) - CS%Temp_Ice)) + ISS%water_flux(i,j) = -ISS%tflux_ocn(i,j) / & + (CS%Lat_fusion + CS%Cp_ice * (ISS%tfreeze(i,j) - CS%Temp_Ice)) ISS%tflux_shelf(i,j) = ISS%tflux_ocn(i,j) + CS%Lat_fusion*ISS%water_flux(i,j) endif @@ -609,9 +608,9 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) ! 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 ((ISS%mass_shelf(i,j)) < US%RZ_to_kg_m2*CS%Rho0*CS%cutoff_depth) then - ISS%water_flux(i,j) = 0.0 - fluxes%iceshelf_melt(i,j) = 0.0 + if (ISS%mass_shelf(i,j) < CS%Rho0*CS%cutoff_depth) 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)) @@ -651,11 +650,12 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) ! Melting has been computed, now is time to update thickness and mass if ( CS%override_shelf_movement .and. (.not.CS%mass_from_file)) then - call change_thickness_using_melt(ISS, G, time_step, fluxes, CS%rho_ice, CS%debug) + call change_thickness_using_melt(ISS, G, US, US%s_to_T*time_step, fluxes, CS%density_ice, CS%debug) if (CS%debug) then call hchksum(ISS%h_shelf, "h_shelf after change thickness using melt", G%HI, haloshift=0, scale=US%Z_to_m) - call hchksum(ISS%mass_shelf, "mass_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, & + scale=US%RZ_to_kg_m2) endif endif @@ -690,7 +690,7 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) 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_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) @@ -706,21 +706,23 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) end subroutine shelf_calc_flux !> 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) +subroutine change_thickness_using_melt(ISS, G, US, time_step, fluxes, density_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 [s]. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, intent(in) :: time_step !< The time step for this update [T ~> s]. 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 [kg m-2 Z-1 ~> kg m-3]. + real, intent(in) :: density_ice !< The density of ice-shelf ice [R ~> kg m-3]. logical, optional, intent(in) :: debug !< If present and true, write chksums ! locals - real :: I_rho_ice + real :: I_rho_ice ! Ice specific volume [R-1 ~> m3 kg-1] integer :: i, j - I_rho_ice = 1.0 / rho_ice + I_rho_ice = 1.0 / density_ice + 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 @@ -730,8 +732,8 @@ subroutine change_thickness_using_melt(ISS, G, time_step, fluxes, rho_ice, debug 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 (G%US%RZ_T_to_kg_m2s*ISS%water_flux(i,j) * time_step / rho_ice < ISS%h_shelf(i,j)) then - ISS%h_shelf(i,j) = ISS%h_shelf(i,j) - G%US%RZ_T_to_kg_m2s*ISS%water_flux(i,j) * time_step / rho_ice + if (ISS%water_flux(i,j) * time_step / density_ice < ISS%h_shelf(i,j)) then + ISS%h_shelf(i,j) = ISS%h_shelf(i,j) - ISS%water_flux(i,j) * time_step / density_ice 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 @@ -749,7 +751,7 @@ subroutine change_thickness_using_melt(ISS, G, time_step, fluxes, rho_ice, debug !### 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 + ISS%mass_shelf(i,j) = ISS%h_shelf(i,j) * density_ice endif enddo ; enddo @@ -766,7 +768,7 @@ subroutine add_shelf_forces(G, US, CS, forces, do_shelf_area) 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. - real :: kv_rho_ice ! The viscosity of ice divided by its density [m5 kg-1 s-1]. + real :: kv_rho_ice ! The viscosity of ice divided by its density [m3 s-1 R-1 Z-1 ~> m5 kg-1 s-1]. real :: press_ice ! The pressure of the ice shelf per unit area of ocean (not ice) [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 @@ -804,7 +806,7 @@ subroutine add_shelf_forces(G, US, CS, forces, do_shelf_area) !### 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)) * & - US%Z_to_m*US%s_to_T**2*(CS%g_Earth * ISS%mass_shelf(i,j)) + US%RZ_to_kg_m2*US%Z_to_m*US%s_to_T**2*(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 @@ -819,7 +821,7 @@ subroutine add_shelf_forces(G, US, CS, forces, do_shelf_area) ! 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 = US%Z2_T_to_m2_s*CS%kv_ice / (US%R_to_kg_m3*CS%density_ice) + kv_rho_ice = US%Z_to_m*US%Z2_T_to_m2_s*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) + & @@ -857,7 +859,7 @@ subroutine add_shelf_pressure(G, US, CS, fluxes) do j=js,je ; do i=is,ie press_ice = (CS%ISS%area_shelf_h(i,j) * G%IareaT(i,j)) * & - US%Z_to_m*US%s_to_T**2*(CS%g_Earth * CS%ISS%mass_shelf(i,j)) + US%RZ_to_kg_m2*US%Z_to_m*US%s_to_T**2*(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 @@ -895,7 +897,7 @@ subroutine add_shelf_flux(G, US, CS, state, fluxes) real :: t0 !< The previous time (Time-dt) [s]. type(time_type) :: Time0!< The previous time (Time-dt) real, dimension(SZDI_(G),SZDJ_(G)) :: last_mass_shelf !< Ice shelf mass - !! at at previous time (Time-dt) [kg m-2] + !! at at previous time (Time-dt) [R Z ~> kg m-2] real, dimension(SZDI_(G),SZDJ_(G)) :: last_h_shelf !< Ice shelf thickness [Z ~> m] !! at at previous time (Time-dt) real, dimension(SZDI_(G),SZDJ_(G)) :: last_hmask !< Ice shelf mask @@ -1023,14 +1025,16 @@ subroutine add_shelf_flux(G, US, CS, state, fluxes) Time0 = real_to_time(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%rho_ice + ! This should only be done if time_interp_external did an update. + last_mass_shelf(:,:) = US%kg_m3_to_R*US%m_to_Z * last_mass_shelf(:,:) ! Rescale after time_interp + 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%rho_ice + last_mass_shelf(:,:) = last_h_shelf(:,:) * CS%density_ice endif shelf_mass0 = 0.0; shelf_mass1 = 0.0 @@ -1039,8 +1043,8 @@ subroutine add_shelf_flux(G, US, CS, state, fluxes) ! 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) * US%L_to_m**2*ISS%area_shelf_h(i,j)) - shelf_mass1 = shelf_mass1 + (ISS%mass_shelf(i,j) * US%L_to_m**2*ISS%area_shelf_h(i,j)) + shelf_mass0 = shelf_mass0 + US%RZ_to_kg_m2*US%L_to_m**2*(last_mass_shelf(i,j) * ISS%area_shelf_h(i,j)) + shelf_mass1 = shelf_mass1 + US%RZ_to_kg_m2*US%L_to_m**2*(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) @@ -1106,6 +1110,8 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl type(dyn_horgrid_type), pointer :: dG => NULL() real :: Z_rescale ! A rescaling factor for heights from the representation in ! a restart file to the internal representation in this run. + real :: RZ_rescale ! A rescaling factor for mass loads from the representation in + ! a restart file to the internal representation in this run. real :: L_rescale ! A rescaling factor for horizontal lengths from the representation in ! a restart file to the internal representation in this run. real :: cdrag, drag_bg_vel @@ -1362,7 +1368,6 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl call get_param(param_file, mdl, "DENSITY_ICE", CS%density_ice, & "A typical density of ice.", units="kg m-3", default=900.0, scale=US%kg_m3_to_R) endif - CS%rho_ice = CS%density_ice*US%Z_to_m*US%R_to_kg_m3 call get_param(param_file, mdl, "MIN_THICKNESS_SIMPLE_CALVE", & CS%min_thickness_simple_calve, & "Min thickness rule for the very simple calving law",& @@ -1431,6 +1436,8 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl "Height unit conversion factor", "Z meter-1") call register_restart_field(US%m_to_L_restart, "m_to_L", .false., CS%restart_CSp, & "Length unit conversion factor", "L meter-1") + call register_restart_field(US%kg_m3_to_R_restart, "kg_m3_to_R", .false., CS%restart_CSp, & + "Density unit conversion factor", "R m3 kg-1") if (CS%active_shelf_dynamics) then call register_restart_field(ISS%hmask, "h_mask", .true., CS%restart_CSp, & "ice sheet/shelf thickness mask" ,"none") @@ -1465,7 +1472,7 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl ! next make sure mass is consistent with thickness do j=G%jsd,G%jed ; do i=G%isd,G%ied if ((ISS%hmask(i,j) == 1) .or. (ISS%hmask(i,j) == 2)) then - ISS%mass_shelf(i,j) = ISS%h_shelf(i,j)*CS%rho_ice + ISS%mass_shelf(i,j) = ISS%h_shelf(i,j)*CS%density_ice endif enddo ; enddo @@ -1493,7 +1500,7 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl ! next make sure mass is consistent with thickness do j=G%jsd,G%jed ; do i=G%isd,G%ied if ((ISS%hmask(i,j) == 1) .or. (ISS%hmask(i,j) == 2)) then - ISS%mass_shelf(i,j) = ISS%h_shelf(i,j)*CS%rho_ice + ISS%mass_shelf(i,j) = ISS%h_shelf(i,j)*CS%density_ice endif enddo ; enddo @@ -1511,6 +1518,14 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl enddo ; enddo endif + if ((US%m_to_Z_restart*US%kg_m3_to_R_restart /= 0.0) .and. & + (US%m_to_Z*US%kg_m3_to_R /= US%m_to_Z_restart * US%kg_m3_to_R_restart)) then + RZ_rescale = US%m_to_Z*US%kg_m3_to_R / (US%m_to_Z_restart * US%kg_m3_to_R_restart) + do j=G%jsc,G%jec ; do i=G%isc,G%iec + ISS%mass_shelf(i,j) = RZ_rescale * ISS%mass_shelf(i,j) + enddo ; enddo + endif + if ((US%m_to_L_restart /= 0.0) .and. (US%m_to_L_restart /= US%m_to_L)) then L_rescale = US%m_to_L / US%m_to_L_restart do j=G%jsc,G%jec ; do i=G%isc,G%iec @@ -1575,7 +1590,7 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl CS%id_area_shelf_h = register_diag_field('ocean_model', 'area_shelf_h', CS%diag%axesT1, CS%Time, & 'Ice Shelf Area in cell', 'meter-2', conversion=US%L_to_m**2) CS%id_shelf_mass = register_diag_field('ocean_model', 'shelf_mass', CS%diag%axesT1, CS%Time, & - 'mass of shelf', 'kg/m^2') + 'mass of shelf', 'kg/m^2', conversion=US%RZ_to_kg_m2) CS%id_h_shelf = register_diag_field('ocean_model', 'h_shelf', CS%diag%axesT1, CS%Time, & 'ice shelf thickness', 'm', conversion=US%Z_to_m) CS%id_mass_flux = register_diag_field('ocean_model', 'mass_flux', CS%diag%axesT1,& @@ -1695,8 +1710,9 @@ subroutine initialize_shelf_mass(G, param_file, CS, ISS, new_sim) end subroutine initialize_shelf_mass !> Updates the ice shelf mass using data from a file. -subroutine update_shelf_mass(G, CS, ISS, Time) +subroutine update_shelf_mass(G, US, CS, ISS, Time) type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(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 @@ -1706,13 +1722,15 @@ subroutine update_shelf_mass(G, CS, ISS, Time) is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec call time_interp_external(CS%id_read_mass, Time, ISS%mass_shelf) + ! This should only be done if time_interp_external did an update. + ISS%mass_shelf(:,:) = US%kg_m3_to_R*US%m_to_Z * ISS%mass_shelf(:,:) ! Rescale after time_interp do j=js,je ; do i=is,ie 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%rho_ice + ISS%h_shelf(i,j) = ISS%mass_shelf(i,j) / CS%density_ice ISS%hmask(i,j) = 1. endif enddo ; enddo diff --git a/src/ice_shelf/MOM_ice_shelf_dynamics.F90 b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 index cf82092dc5..e8d6f9b3c1 100644 --- a/src/ice_shelf/MOM_ice_shelf_dynamics.F90 +++ b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 @@ -1969,7 +1969,7 @@ subroutine shelf_advance_front(CS, ISS, G, flux_enter) ISS%area_shelf_h(i,j) = dxdyh elseif ((partial_vol / dxdyh) < h_reference) then ISS%hmask(i,j) = 2 - ! ISS%mass_shelf(i,j) = G%US%L_to_m**2*partial_vol * rho + ! ISS%mass_shelf(i,j) = G%US%L_to_Z*G%US%L_to_m*partial_vol * G%US%kg_m3_to_R*rho ISS%area_shelf_h(i,j) = partial_vol / h_reference ISS%h_shelf(i,j) = h_reference else diff --git a/src/ice_shelf/MOM_ice_shelf_state.F90 b/src/ice_shelf/MOM_ice_shelf_state.F90 index 98b5d01939..b3e88697f2 100644 --- a/src/ice_shelf/MOM_ice_shelf_state.F90 +++ b/src/ice_shelf/MOM_ice_shelf_state.F90 @@ -23,9 +23,9 @@ module MOM_ice_shelf_state !> 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 [kg m-2]. + mass_shelf => NULL(), & !< The mass per unit area of the ice shelf or sheet [R Z ~> kg m-2]. area_shelf_h => NULL(), & !< The area per cell covered by the ice shelf [L2 ~> m2]. - h_shelf => NULL(), & !< the thickness of the shelf [m], redundant with mass but may + h_shelf => NULL(), & !< the thickness of the shelf [Z ~> 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 diff --git a/src/ice_shelf/user_shelf_init.F90 b/src/ice_shelf/user_shelf_init.F90 index 100f8e652a..54b452fc6a 100644 --- a/src/ice_shelf/user_shelf_init.F90 +++ b/src/ice_shelf/user_shelf_init.F90 @@ -27,7 +27,7 @@ module user_shelf_init !> The control structure for the user_ice_shelf module type, public :: user_ice_shelf_CS ; private - real :: Rho_ocean !< The ocean's typical density [kg m-2 Z-1]. + real :: Rho_ocean !< The ocean's typical density [R ~> kg m-3]. real :: max_draft !< The maximum ocean draft of the ice shelf [Z ~> m]. real :: min_draft !< The minimum ocean draft of the ice shelf [Z ~> m]. real :: flat_shelf_width !< The range over which the shelf is min_draft thick [km]. @@ -45,7 +45,7 @@ subroutine USER_initialize_shelf_mass(mass_shelf, area_shelf_h, h_shelf, hmask, 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 [kg m-2]. + !! over the full ocean cell [R Z ~> kg m-2]. real, dimension(SZDI_(G),SZDJ_(G)), & intent(out) :: h_shelf !< The ice shelf thickness [Z ~> m]. real, dimension(SZDI_(G),SZDJ_(G)), & @@ -60,7 +60,6 @@ subroutine USER_initialize_shelf_mass(mass_shelf, area_shelf_h, h_shelf, hmask, !! being started from a restart file. ! This subroutine sets up the initial mass and area covered by the ice shelf. - real :: Rho_ocean ! The ocean's typical density [kg m-3]. real :: max_draft ! The maximum ocean draft of the ice shelf [Z ~> m]. real :: min_draft ! The minimum ocean draft of the ice shelf [Z ~> m]. real :: flat_shelf_width ! The range over which the shelf is min_draft thick. @@ -81,7 +80,7 @@ subroutine USER_initialize_shelf_mass(mass_shelf, area_shelf_h, h_shelf, hmask, "calculate accelerations and the mass for conservation "//& "properties, or with BOUSSINSEQ false to convert some "//& "parameters from vertical units of m to kg m-2.", & - units="kg m-3", default=1035.0, scale=US%Z_to_m) + units="kg m-3", default=1035.0, scale=US%kg_m3_to_R) call get_param(param_file, mdl, "SHELF_MAX_DRAFT", CS%max_draft, & units="m", default=1.0, scale=US%m_to_Z) call get_param(param_file, mdl, "SHELF_MIN_DRAFT", CS%min_draft, & @@ -126,7 +125,7 @@ subroutine USER_update_shelf_mass(mass_shelf, area_shelf_h, h_shelf, hmask, G, C 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 [kg m-2]. + !! over the full ocean cell [R Z ~> kg m-2]. real, dimension(SZDI_(G),SZDJ_(G)), & intent(inout) :: area_shelf_h !< The area per cell covered by the ice shelf [L2 ~> m2]. real, dimension(SZDI_(G),SZDJ_(G)), & From 2fe5224543c49c77c45fbca7d36a908543850231 Mon Sep 17 00:00:00 2001 From: Mariana Vertenstein Date: Mon, 23 Mar 2020 20:28:05 -0600 Subject: [PATCH 120/316] updates to clean up differences between nems and cmeps for restarts --- config_src/nuopc_driver/mom_cap.F90 | 894 ++++++++-------------------- 1 file changed, 246 insertions(+), 648 deletions(-) diff --git a/config_src/nuopc_driver/mom_cap.F90 b/config_src/nuopc_driver/mom_cap.F90 index 219245e473..ba3c3e80d8 100644 --- a/config_src/nuopc_driver/mom_cap.F90 +++ b/config_src/nuopc_driver/mom_cap.F90 @@ -70,6 +70,8 @@ module MOM_cap_mod use ESMF, only: ESMF_MESHLOC_ELEMENT, ESMF_RC_VAL_OUTOFRANGE, ESMF_StateGet use ESMF, only: ESMF_TimePrint, ESMF_AlarmSet, ESMF_FieldGet, ESMF_Array use ESMF, only: ESMF_ArrayCreate +use ESMF, only: ESMF_RC_FILE_OPEN, ESMF_RC_FILE_READ, ESMF_RC_FILE_WRITE +use ESMF, only: ESMF_VMBroadcast use ESMF, only: operator(==), operator(/=), operator(+), operator(-) ! TODO ESMF_GridCompGetInternalState does not have an explicit Fortran interface. @@ -258,95 +260,54 @@ subroutine InitializeP0(gcomp, importState, exportState, clock, rc) ! Switch to IPDv03 by filtering all other phaseMap entries call NUOPC_CompFilterPhaseMap(gcomp, ESMF_METHOD_INITIALIZE, & acceptStringList=(/"IPDv03p"/), rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return write_diagnostics = .false. call NUOPC_CompAttributeGet(gcomp, name="DumpFields", value=value, & isPresent=isPresent, isSet=isSet, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return if (isPresent .and. isSet) write_diagnostics=(trim(value)=="true") write(logmsg,*) write_diagnostics - call ESMF_LogWrite('MOM_cap:DumpFields = '//trim(logmsg), ESMF_LOGMSG_INFO, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return + call ESMF_LogWrite('MOM_cap:DumpFields = '//trim(logmsg), ESMF_LOGMSG_INFO) overwrite_timeslice = .false. call NUOPC_CompAttributeGet(gcomp, name="OverwriteSlice", value=value, & isPresent=isPresent, isSet=isSet, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return if (isPresent .and. isSet) overwrite_timeslice=(trim(value)=="true") write(logmsg,*) overwrite_timeslice - call ESMF_LogWrite('MOM_cap:OverwriteSlice = '//trim(logmsg), ESMF_LOGMSG_INFO, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return + call ESMF_LogWrite('MOM_cap:OverwriteSlice = '//trim(logmsg), ESMF_LOGMSG_INFO) profile_memory = .false. call NUOPC_CompAttributeGet(gcomp, name="ProfileMemory", value=value, & isPresent=isPresent, isSet=isSet, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return if (isPresent .and. isSet) profile_memory=(trim(value)=="true") write(logmsg,*) profile_memory - call ESMF_LogWrite('MOM_cap:ProfileMemory = '//trim(logmsg), ESMF_LOGMSG_INFO, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return + call ESMF_LogWrite('MOM_cap:ProfileMemory = '//trim(logmsg), ESMF_LOGMSG_INFO) grid_attach_area = .false. call NUOPC_CompAttributeGet(gcomp, name="GridAttachArea", value=value, & isPresent=isPresent, isSet=isSet, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return if (isPresent .and. isSet) grid_attach_area=(trim(value)=="true") write(logmsg,*) grid_attach_area - call ESMF_LogWrite('MOM_cap:GridAttachArea = '//trim(logmsg), ESMF_LOGMSG_INFO, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return + call ESMF_LogWrite('MOM_cap:GridAttachArea = '//trim(logmsg), ESMF_LOGMSG_INFO) scalar_field_name = "" call NUOPC_CompAttributeGet(gcomp, name="ScalarFieldName", value=value, & isPresent=isPresent, isSet=isSet, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return if (isPresent .and. isSet) then scalar_field_name = trim(value) - call ESMF_LogWrite('MOM_cap:ScalarFieldName = '//trim(scalar_field_name), ESMF_LOGMSG_INFO, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return + call ESMF_LogWrite('MOM_cap:ScalarFieldName = '//trim(scalar_field_name), ESMF_LOGMSG_INFO) endif scalar_field_count = 0 call NUOPC_CompAttributeGet(gcomp, name="ScalarFieldCount", value=value, & isPresent=isPresent, isSet=isSet, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return if (isPresent .and. isSet) then read(value, '(i)', iostat=iostat) scalar_field_count if (iostat /= 0) then @@ -356,20 +317,13 @@ subroutine InitializeP0(gcomp, importState, exportState, clock, rc) return endif write(logmsg,*) scalar_field_count - call ESMF_LogWrite('MOM_cap:ScalarFieldCount = '//trim(logmsg), ESMF_LOGMSG_INFO, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return + call ESMF_LogWrite('MOM_cap:ScalarFieldCount = '//trim(logmsg), ESMF_LOGMSG_INFO) endif scalar_field_idx_grid_nx = 0 call NUOPC_CompAttributeGet(gcomp, name="ScalarFieldIdxGridNX", value=value, & isPresent=isPresent, isSet=isSet, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return if (isPresent .and. isSet) then read(value, '(i)', iostat=iostat) scalar_field_idx_grid_nx if (iostat /= 0) then @@ -379,20 +333,13 @@ subroutine InitializeP0(gcomp, importState, exportState, clock, rc) return endif write(logmsg,*) scalar_field_idx_grid_nx - call ESMF_LogWrite('MOM_cap:ScalarFieldIdxGridNX = '//trim(logmsg), ESMF_LOGMSG_INFO, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return + call ESMF_LogWrite('MOM_cap:ScalarFieldIdxGridNX = '//trim(logmsg), ESMF_LOGMSG_INFO) endif scalar_field_idx_grid_ny = 0 call NUOPC_CompAttributeGet(gcomp, name="ScalarFieldIdxGridNY", value=value, & isPresent=isPresent, isSet=isSet, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return if (isPresent .and. isSet) then read(value, '(i)', iostat=iostat) scalar_field_idx_grid_ny if (iostat /= 0) then @@ -402,20 +349,9 @@ subroutine InitializeP0(gcomp, importState, exportState, clock, rc) return endif write(logmsg,*) scalar_field_idx_grid_ny - call ESMF_LogWrite('MOM_cap:ScalarFieldIdxGridNY = '//trim(logmsg), ESMF_LOGMSG_INFO, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return + call ESMF_LogWrite('MOM_cap:ScalarFieldIdxGridNY = '//trim(logmsg), ESMF_LOGMSG_INFO) endif - call NUOPC_CompAttributeAdd(gcomp, & - attrList=(/'RestartFileToRead', 'RestartFileToWrite'/), rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return - end subroutine !> Called by NUOPC to advertise import and export fields. "Advertise" @@ -462,6 +398,9 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) logical :: isPresent, isPresentDiro, isPresentLogfile, isSet logical :: existflag integer :: userRc + integer :: localPet + integer :: iostat + integer :: readunit character(len=512) :: restartfile ! Path/Name of restart file character(len=*), parameter :: subname='(MOM_cap:InitializeAdvertise)' character(len=32) :: calendar @@ -469,11 +408,7 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) rc = ESMF_SUCCESS - call ESMF_LogWrite(subname//' enter', ESMF_LOGMSG_INFO, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return + call ESMF_LogWrite(subname//' enter', ESMF_LOGMSG_INFO) allocate(Ice_ocean_boundary) !allocate(ocean_state) ! ocean_model_init allocate this pointer @@ -484,34 +419,19 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) ocean_internalstate%ptr%ocean_state_type_ptr => ocean_state call ESMF_VMGetCurrent(vm, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return call ESMF_VMGet(VM, mpiCommunicator=mpi_comm_mom, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return call ESMF_ClockGet(CLOCK, currTIME=MyTime, TimeStep=TINT, RC=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return call ESMF_TimeGet (MyTime, YY=YEAR, MM=MONTH, DD=DAY, H=HOUR, M=MINUTE, S=SECOND, RC=rc ) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return CALL ESMF_TimeIntervalGet(TINT, S=DT_OCEAN, RC=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return call fms_init(mpi_comm_mom) call constants_init @@ -521,10 +441,7 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) if (cesm_coupled) then call NUOPC_CompAttributeGet(gcomp, name="calendar", value=cvalue, & isPresent=isPresent, isSet=isSet, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return if (isPresent .and. isSet) then read(cvalue,*) calendar select case (trim(calendar)) @@ -558,16 +475,10 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) ! get start/reference time call ESMF_ClockGet(CLOCK, refTime=MyTime, RC=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return call ESMF_TimeGet (MyTime, YY=YEAR, MM=MONTH, DD=DAY, H=HOUR, M=MINUTE, S=SECOND, RC=rc ) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return time0 = set_date (YEAR,MONTH,DAY,HOUR,MINUTE,SECOND) @@ -583,27 +494,15 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) if (is_root_pe()) then call NUOPC_CompAttributeGet(gcomp, name="diro", & isPresent=isPresentDiro, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return call NUOPC_CompAttributeGet(gcomp, name="logfile", & isPresent=isPresentLogfile, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return if (isPresentDiro .and. isPresentLogfile) then - call NUOPC_CompAttributeGet(gcomp, name="diro", value=diro, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return - call NUOPC_CompAttributeGet(gcomp, name="logfile", value=logfile, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return + call NUOPC_CompAttributeGet(gcomp, name="diro", value=diro, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + call NUOPC_CompAttributeGet(gcomp, name="logfile", value=logfile, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return open(newunit=logunit,file=trim(diro)//"/"//trim(logfile)) else logunit = output_unit @@ -615,19 +514,11 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) starttype = "" call NUOPC_CompAttributeGet(gcomp, name='start_type', value=cvalue, & isPresent=isPresent, isSet=isSet, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return if (isPresent .and. isSet) then read(cvalue,*) starttype else - call ESMF_LogWrite('MOM_cap:start_type unset - using input.nml for restart option', & - ESMF_LOGMSG_INFO, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return + call ESMF_LogWrite('MOM_cap:start_type unset - using input.nml for restart option', ESMF_LOGMSG_INFO) endif runtype = "" @@ -645,58 +536,44 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) endif if (len_trim(runtype) > 0) then - call ESMF_LogWrite('MOM_cap:startup = '//trim(runtype), ESMF_LOGMSG_INFO, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return + call ESMF_LogWrite('MOM_cap:startup = '//trim(runtype), ESMF_LOGMSG_INFO) endif restartfile = "" if (runtype == "initial") then - ! startup (new run) - 'n' is needed below if we don't specify input_filename in input.nml + restartfile = "n" - else if (runtype == "continue") then ! hybrid or branch or continuos runs - ! optionally call into system-specific implementation to get restart file name - call ESMF_MethodExecute(gcomp, label="GetRestartFileToRead", & - existflag=existflag, userRc=userRc, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg="Error executing user method to get restart filename", & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - if (ESMF_LogFoundError(rcToCheck=userRc, msg="Error in method to get restart filename", & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - if (existflag) then - call ESMF_LogWrite('MOM_cap: called user GetRestartFileToRead', ESMF_LOGMSG_INFO, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return - endif + else if (runtype == "continue") then ! hybrid or branch or continuos runs - call NUOPC_CompAttributeGet(gcomp, name='RestartFileToRead', & - value=cvalue, isPresent=isPresent, isSet=isSet, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return - if (isPresent .and. isSet) then - restartfile = trim(cvalue) - call ESMF_LogWrite('MOM_cap: RestartFileToRead = '//trim(restartfile), ESMF_LOGMSG_INFO, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return + if (cesm_coupled) then + call ESMF_LogWrite('MOM_cap: restart requested, using rpointer.ocn', ESMF_LOGMSG_WARNING) + call ESMF_GridCompGet(gcomp, vm=vm, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + call ESMF_VMGet(vm, localPet=localPet, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + + if (localPet == 0) then + ! this hard coded for rpointer.ocn right now + open(newunit=readunit, file='rpointer.ocn', form='formatted', status='old', iostat=iostat) + if (iostat /= 0) then + call ESMF_LogSetError(ESMF_RC_FILE_OPEN, msg=subname//' ERROR opening rpointer.ocn', & + line=__LINE__, file=u_FILE_u, rcToReturn=rc) + return + endif + read(readunit,'(a)', iostat=iostat) restartfile + if (iostat /= 0) then + call ESMF_LogSetError(ESMF_RC_FILE_READ, msg=subname//' ERROR reading rpointer.ocn', & + line=__LINE__, file=u_FILE_u, rcToReturn=rc) + return + endif + close(readunit) + endif + ! broadcast attribute set on master task to all tasks + call ESMF_VMBroadcast(vm, restartfile, count=ESMF_MAXSTR-1, rootPet=0, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return else - call ESMF_LogWrite('MOM_cap: restart requested, no RestartFileToRead attribute provided-will use input.nml',& - ESMF_LOGMSG_WARNING, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return + call ESMF_LogWrite('MOM_cap: restart requested, use input.nml', ESMF_LOGMSG_WARNING) endif endif @@ -905,10 +782,7 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) !---------------------------------------------------------------------------- call ESMF_GridCompGetInternalState(gcomp, ocean_internalstate, rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return Ice_ocean_boundary => ocean_internalstate%ptr%ice_ocean_boundary_type_ptr ocean_public => ocean_internalstate%ptr%ocean_public_type_ptr @@ -919,16 +793,9 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) !---------------------------------------------------------------------------- call ESMF_VMGetCurrent(vm, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return call ESMF_VMGet(vm, petCount=npet, mpiCommunicator=mpicom, localPet=localPet, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return !--------------------------------- ! global mom grid size @@ -936,11 +803,7 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) call mpp_get_global_domain(ocean_public%domain, xsize=nxg, ysize=nyg) write(tmpstr,'(a,2i6)') subname//' nxg,nyg = ',nxg,nyg - call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO) !--------------------------------- ! number of tiles per PET, assumed to be 1, and number of pes (tiles) total @@ -949,19 +812,11 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) ntiles=mpp_get_ntile_count(ocean_public%domain) ! this is tiles on this pe if (ntiles /= 1) then rc = ESMF_FAILURE - call ESMF_LogWrite(subname//' ntiles must be 1', ESMF_LOGMSG_ERROR, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return + call ESMF_LogWrite(subname//' ntiles must be 1', ESMF_LOGMSG_ERROR) endif ntiles=mpp_get_domain_npes(ocean_public%domain) write(tmpstr,'(a,1i6)') subname//' ntiles = ',ntiles - call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return + call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO) !--------------------------------- ! get start and end indices of each tile and their PET @@ -973,11 +828,7 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) if (debug > 0) then do n = 1,ntiles write(tmpstr,'(a,6i6)') subname//' tiles ',n,pe(n),xb(n),xe(n),yb(n),ye(n) - call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return + call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO) enddo endif @@ -1010,23 +861,14 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) enddo DistGrid = ESMF_DistGridCreate(arbSeqIndexList=gindex, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return ! read in the mesh call NUOPC_CompAttributeGet(gcomp, name='mesh_ocn', value=cvalue, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return EMeshTemp = ESMF_MeshCreate(filename=trim(cvalue), fileformat=ESMF_FILEFORMAT_ESMFMESH, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return if (localPet == 0) then write(logunit,*)'mesh file for mom6 domain is ',trim(cvalue) @@ -1034,17 +876,11 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) ! recreate the mesh using the above distGrid EMesh = ESMF_MeshCreate(EMeshTemp, elementDistgrid=Distgrid, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return ! Check for consistency of lat, lon and mask between mesh and mom6 grid call ESMF_MeshGet(Emesh, spatialDim=spatialDim, numOwnedElements=numOwnedElements, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return allocate(ownedElemCoords(spatialDim*numOwnedElements)) allocate(lonMesh(numOwnedElements), lon(numOwnedElements)) @@ -1062,15 +898,10 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) end do elemMaskArray = ESMF_ArrayCreate(Distgrid, maskMesh, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + call ESMF_MeshGet(Emesh, elemMaskArray=elemMaskArray, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return call mpp_get_compute_domain(ocean_public%domain, isc, iec, jsc, jec) n = 0 @@ -1117,16 +948,10 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) deallocate(maskMesh, mask) ! realize the import and export fields using the mesh call MOM_RealizeFields(importState, fldsToOcn_num, fldsToOcn, "Ocn import", mesh=Emesh, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return call MOM_RealizeFields(exportState, fldsFrOcn_num, fldsFrOcn, "Ocn export", mesh=Emesh, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return else if (geomtype == ESMF_GEOMTYPE_GRID) then @@ -1148,19 +973,16 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) deBlockList(2,2,n) = ye(n) petMap(n) = pe(n) ! write(tmpstr,'(a,3i8)') subname//' iglo = ',n,deBlockList(1,1,n),deBlockList(1,2,n) - ! call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO, rc=rc) + ! call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO) ! write(tmpstr,'(a,3i8)') subname//' jglo = ',n,deBlockList(2,1,n),deBlockList(2,2,n) - ! call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO, rc=rc) + ! call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO) ! write(tmpstr,'(a,2i8)') subname//' pe = ',n,petMap(n) - ! call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO, rc=rc) + ! call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO) !--- assume a tile with starting index of 1 has an equivalent wraparound tile on the other side enddo delayout = ESMF_DELayoutCreate(petMap, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return ! rsd this assumes tripole grid, but sometimes in CESM a bipole ! grid is used -- need to introduce conditional logic here @@ -1171,18 +993,12 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) call ESMF_DistGridConnectionSet(connectionList(1), tileIndexA=1, & tileIndexB=1, positionVector=(/nxg+1, 2*nyg+1/), & orientationVector=(/-1, -2/), rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return ! periodic boundary condition along first dimension call ESMF_DistGridConnectionSet(connectionList(2), tileIndexA=1, & tileIndexB=1, positionVector=(/nxg, 0/), rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return distgrid = ESMF_DistGridCreate(minIndex=(/1,1/), maxIndex=(/nxg,nyg/), & ! indexflag = ESMF_INDEX_DELOCAL, & @@ -1191,10 +1007,7 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) delayout=delayout, & connectionList=connectionList, & rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return deallocate(xb,xe,yb,ye,pe) deallocate(connectionList) @@ -1203,32 +1016,18 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) deallocate(petMap) call ESMF_DistGridGet(distgrid=distgrid, localDE=0, elementCount=cnt, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return allocate(indexList(cnt)) write(tmpstr,'(a,i8)') subname//' distgrid cnt= ',cnt - call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return + call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO) call ESMF_DistGridGet(distgrid=distgrid, localDE=0, seqIndexList=indexList, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return write(tmpstr,'(a,4i8)') subname//' distgrid list= ',& indexList(1),indexList(cnt),minval(indexList), maxval(indexList) - call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return + call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO) deallocate(IndexList) @@ -1238,91 +1037,55 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) gridEdgeLWidth=(/0,0/), gridEdgeUWidth=(/0,1/), & coordSys = ESMF_COORDSYS_SPH_DEG, & rc = rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return - + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return call ESMF_GridAddCoord(gridIn, staggerLoc=ESMF_STAGGERLOC_CENTER, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return call ESMF_GridAddCoord(gridIn, staggerLoc=ESMF_STAGGERLOC_CORNER, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return call ESMF_GridAddItem(gridIn, itemFlag=ESMF_GRIDITEM_MASK, itemTypeKind=ESMF_TYPEKIND_I4, & staggerLoc=ESMF_STAGGERLOC_CENTER, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return ! Attach area to the Grid optionally. By default the cell areas are computed. if(grid_attach_area) then call ESMF_GridAddItem(gridIn, itemFlag=ESMF_GRIDITEM_AREA, itemTypeKind=ESMF_TYPEKIND_R8, & staggerLoc=ESMF_STAGGERLOC_CENTER, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return - + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return endif call ESMF_GridGetCoord(gridIn, coordDim=1, & staggerloc=ESMF_STAGGERLOC_CENTER, & farrayPtr=dataPtr_xcen, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return call ESMF_GridGetCoord(gridIn, coordDim=2, & staggerloc=ESMF_STAGGERLOC_CENTER, & farrayPtr=dataPtr_ycen, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return - + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return call ESMF_GridGetCoord(gridIn, coordDim=1, & staggerloc=ESMF_STAGGERLOC_CORNER, & farrayPtr=dataPtr_xcor, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return call ESMF_GridGetCoord(gridIn, coordDim=2, & staggerloc=ESMF_STAGGERLOC_CORNER, & farrayPtr=dataPtr_ycor, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return call ESMF_GridGetItem(gridIn, itemflag=ESMF_GRIDITEM_MASK, & staggerloc=ESMF_STAGGERLOC_CENTER, & farrayPtr=dataPtr_mask, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return if(grid_attach_area) then call ESMF_GridGetItem(gridIn, itemflag=ESMF_GRIDITEM_AREA, & staggerloc=ESMF_STAGGERLOC_CENTER, & farrayPtr=dataPtr_area, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return endif ! load up area, mask, center and corner values @@ -1345,13 +1108,13 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) ubnd4 = ubound(dataPtr_xcor,2) write(tmpstr,*) subname//' iscjsc = ',isc,iec,jsc,jec - call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO, rc=rc) + call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO) write(tmpstr,*) subname//' lbub12 = ',lbnd1,ubnd1,lbnd2,ubnd2 - call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO, rc=rc) + call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO) write(tmpstr,*) subname//' lbub34 = ',lbnd3,ubnd3,lbnd4,ubnd4 - call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO, rc=rc) + call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO) if (iec-isc /= ubnd1-lbnd1 .or. jec-jsc /= ubnd2-lbnd2) then call ESMF_LogSetError(ESMF_RC_ARG_BAD, & @@ -1390,38 +1153,32 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) enddo write(tmpstr,*) subname//' mask = ',minval(dataPtr_mask),maxval(dataPtr_mask) - call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO, rc=rc) + call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO) if(grid_attach_area) then write(tmpstr,*) subname//' area = ',minval(dataPtr_area),maxval(dataPtr_area) - call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO, rc=rc) + call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO) endif write(tmpstr,*) subname//' xcen = ',minval(dataPtr_xcen),maxval(dataPtr_xcen) - call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO, rc=rc) + call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO) write(tmpstr,*) subname//' ycen = ',minval(dataPtr_ycen),maxval(dataPtr_ycen) - call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO, rc=rc) + call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO) write(tmpstr,*) subname//' xcor = ',minval(dataPtr_xcor),maxval(dataPtr_xcor) - call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO, rc=rc) + call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO) write(tmpstr,*) subname//' ycor = ',minval(dataPtr_ycor),maxval(dataPtr_ycor) - call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO, rc=rc) + call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO) gridOut = gridIn ! for now out same as in call MOM_RealizeFields(importState, fldsToOcn_num, fldsToOcn, "Ocn import", grid=gridIn, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return call MOM_RealizeFields(exportState, fldsFrOcn_num, fldsFrOcn, "Ocn export", grid=gridOut, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return endif @@ -1432,18 +1189,11 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) if (len_trim(scalar_field_name) > 0) then call State_SetScalar(dble(nxg),scalar_field_idx_grid_nx, exportState, localPet, & scalar_field_name, scalar_field_count, rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return call State_SetScalar(dble(nyg),scalar_field_idx_grid_ny, exportState, localPet, & scalar_field_name, scalar_field_count, rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return - + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return endif !--------------------------------- @@ -1489,16 +1239,10 @@ subroutine DataInitialize(gcomp, rc) ! query the Component for its clock, importState and exportState call ESMF_GridCompGet(gcomp, clock=clock, importState=importState, exportState=exportState, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return call ESMF_GridCompGetInternalState(gcomp, ocean_internalstate, rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return Ice_ocean_boundary => ocean_internalstate%ptr%ice_ocean_boundary_type_ptr ocean_public => ocean_internalstate%ptr%ocean_public_type_ptr @@ -1506,48 +1250,27 @@ subroutine DataInitialize(gcomp, rc) call get_ocean_grid(ocean_state, ocean_grid) call mom_export(ocean_public, ocean_grid, ocean_state, exportState, clock, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return call ESMF_StateGet(exportState, itemCount=fieldCount, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return allocate(fieldNameList(fieldCount)) call ESMF_StateGet(exportState, itemNameList=fieldNameList, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return do n=1, fieldCount call ESMF_StateGet(exportState, itemName=fieldNameList(n), field=field, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return call NUOPC_SetAttribute(field, name="Updated", value="true", rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return enddo deallocate(fieldNameList) ! check whether all Fields in the exportState are "Updated" if (NUOPC_IsUpdated(exportState)) then call NUOPC_CompAttributeSet(gcomp, name="InitializeDataComplete", value="true", rc=rc) - - call ESMF_LogWrite("MOM6 - Initialize-Data-Dependency SATISFIED!!!", ESMF_LOGMSG_INFO, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + call ESMF_LogWrite("MOM6 - Initialize-Data-Dependency SATISFIED!!!", ESMF_LOGMSG_INFO) endif if(write_diagnostics) then @@ -1596,6 +1319,11 @@ subroutine ModelAdvance(gcomp, rc) integer :: seconds, day, year, month, hour, minute character(ESMF_MAXSTR) :: restartname, cvalue character(240) :: msgString + character(ESMF_MAXSTR) :: casename + integer :: iostat + integer :: writeunit + integer :: localPet + type(ESMF_VM) :: vm character(len=*),parameter :: subname='(MOM_cap:ModelAdvance)' rc = ESMF_SUCCESS @@ -1604,45 +1332,21 @@ subroutine ModelAdvance(gcomp, rc) call shr_file_setLogUnit (logunit) ! query the Component for its clock, importState and exportState - call ESMF_GridCompGet(gcomp, clock=clock, importState=importState, & - exportState=exportState, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + call ESMF_GridCompGet(gcomp, clock=clock, importState=importState, exportState=exportState, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return ! HERE THE MODEL ADVANCES: currTime -> currTime + timeStep - call ESMF_ClockPrint(clock, options="currTime", & - preString="------>Advancing OCN from: ", unit=msgString, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - call ESMF_LogWrite(subname//trim(msgString), ESMF_LOGMSG_INFO, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + call ESMF_ClockPrint(clock, options="currTime", preString="------>Advancing OCN from: ", unit=msgString, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + call ESMF_LogWrite(subname//trim(msgString), ESMF_LOGMSG_INFO) - call ESMF_ClockGet(clock, startTime=startTime, currTime=currTime, & - timeStep=timeStep, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + call ESMF_ClockGet(clock, startTime=startTime, currTime=currTime, timeStep=timeStep, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return - call ESMF_TimePrint(currTime + timeStep, & - preString="--------------------------------> to: ", unit=msgString, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - call ESMF_LogWrite(trim(msgString), ESMF_LOGMSG_INFO, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + call ESMF_TimePrint(currTime + timeStep, preString="--------------------------------> to: ", unit=msgString, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + call ESMF_LogWrite(trim(msgString), ESMF_LOGMSG_INFO) Time_step_coupled = esmf2fms_time(timeStep) Time = esmf2fms_time(currTime) @@ -1656,11 +1360,7 @@ subroutine ModelAdvance(gcomp, rc) ! Do not call MOM6 timestepping routine if the first cpl tstep of a startup run if (currTime == startTime) then - call ESMF_LogWrite("MOM6 - Skipping the first coupling timestep", ESMF_LOGMSG_INFO, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + call ESMF_LogWrite("MOM6 - Skipping the first coupling timestep", ESMF_LOGMSG_INFO) do_advance = .false. else do_advance = .true. @@ -1669,18 +1369,9 @@ subroutine ModelAdvance(gcomp, rc) if (do_advance) then ! If the second cpl tstep of a startup run, step back a cpl tstep and advance for two cpl tsteps if (currTime == startTime + timeStep) then - call ESMF_LogWrite("MOM6 - Stepping back one coupling timestep", ESMF_LOGMSG_INFO, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + call ESMF_LogWrite("MOM6 - Stepping back one coupling timestep", ESMF_LOGMSG_INFO) Time = esmf2fms_time(currTime-timeStep) ! i.e., startTime - - call ESMF_LogWrite("MOM6 - doubling the coupling timestep", ESMF_LOGMSG_INFO, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + call ESMF_LogWrite("MOM6 - doubling the coupling timestep", ESMF_LOGMSG_INFO) Time_step_coupled = 2 * esmf2fms_time(timeStep) endif end if @@ -1691,10 +1382,7 @@ subroutine ModelAdvance(gcomp, rc) if (do_advance) then call ESMF_GridCompGetInternalState(gcomp, ocean_internalstate, rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return Ice_ocean_boundary => ocean_internalstate%ptr%ice_ocean_boundary_type_ptr ocean_public => ocean_internalstate%ptr%ocean_public_type_ptr @@ -1707,10 +1395,7 @@ subroutine ModelAdvance(gcomp, rc) if (write_diagnostics) then call NUOPC_Write(importState, fileNamePrefix='field_ocn_import_', & overwrite=overwrite_timeslice,timeslice=import_slice, relaxedFlag=.true., rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return import_slice = import_slice + 1 endif @@ -1725,10 +1410,7 @@ subroutine ModelAdvance(gcomp, rc) !--------------- call mom_import(ocean_public, ocean_grid, importState, ice_ocean_boundary, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return !--------------- ! Update MOM6 @@ -1743,10 +1425,7 @@ subroutine ModelAdvance(gcomp, rc) !--------------- call mom_export(ocean_public, ocean_grid, ocean_state, exportState, clock, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return endif @@ -1755,78 +1434,67 @@ subroutine ModelAdvance(gcomp, rc) !--------------- call ESMF_ClockGetAlarm(clock, alarmname='alarm_restart', alarm=alarm, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return if (ESMF_AlarmIsRinging(alarm, rc=rc)) then - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return call ESMF_AlarmRingerOff(alarm, rc=rc ) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - - ! call into system specific method to get desired restart filename - restartname = "" - call ESMF_MethodExecute(gcomp, label="GetRestartFileToWrite", & - existflag=existflag, userRc=userRc, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg="Error executing user method to get restart filename", & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - - if (ESMF_LogFoundError(rcToCheck=userRc, msg="Error in method to get restart filename", & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - if (existflag) then - call ESMF_LogWrite("MOM_cap: called user GetRestartFileToWrite method", ESMF_LOGMSG_INFO, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - call NUOPC_CompAttributeGet(gcomp, name='RestartFileToWrite', & - isPresent=isPresent, isSet=isSet, value=cvalue, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - if (isPresent .and. isSet) then - restartname = trim(cvalue) - call ESMF_LogWrite("MOM_cap: User RestartFileToWrite: "//trim(restartname), ESMF_LOGMSG_INFO, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + + call ESMF_ClockGetNextTime(clock, MyTime, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + call ESMF_TimeGet (MyTime, yy=year, mm=month, dd=day, h=hour, m=minute, s=seconds, rc=rc ) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + + if (cesm_coupled) then + call NUOPC_CompAttributeGet(gcomp, name='case_name', value=casename, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + call ESMF_GridCompGet(gcomp, vm=vm, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + call ESMF_VMGet(vm, localPet=localPet, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + + write(restartname,'(A,".mom6.r.",I4.4,"-",I2.2,"-",I2.2,"-",I5.5)') & + trim(casename), year, month, day, seconds + if (localPet == 0) then + ! Write name of restart file in the rpointer file - this is currently hard-coded for the ocean + open(newunit=writeunit, file='rpointer.ocn', form='formatted', status='unknown', iostat=iostat) + if (iostat /= 0) then + call ESMF_LogSetError(ESMF_RC_FILE_OPEN, & + msg=subname//' ERROR opening rpointer.ocn', line=__LINE__, file=u_FILE_u, rcToReturn=rc) + return + endif + write(writeunit,'(a)') trim(restartname)//'.nc' + close(writeunit) endif - endif - - if (len_trim(restartname) == 0) then - ! none provided, so use a default restart filename - call ESMF_ClockGetNextTime(clock, MyTime, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - call ESMF_TimeGet (MyTime, yy=year, mm=month, dd=day, & - h=hour, m=minute, s=seconds, rc=rc ) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + else write(restartname,'(A,".mom6.r.",I4.4,"-",I2.2,"-",I2.2,"-",I2.2,"-",I2.2,"-",I2.2)') & "ocn", year, month, day, hour, minute, seconds - call ESMF_LogWrite("MOM_cap: Using default restart filename: "//trim(restartname), ESMF_LOGMSG_INFO, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + endif + call ESMF_LogWrite("MOM_cap: Using restart filename: "//trim(restartname), ESMF_LOGMSG_INFO) + + ! TODO: address if this requirement is being met for the DA group + ! Optionally write restart files when currTime-startTime is integer multiples of restart_interval + ! if (restart_interval > 0 ) then + ! time_elapsed = currTime - startTime + ! call ESMF_TimeIntervalGet(time_elapsed, s_i8=time_elapsed_sec, rc=rc) + ! if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + ! n_interval = time_elapsed_sec / restart_interval + ! if ((n_interval .gt. 0) .and. (n_interval*restart_interval == time_elapsed_sec)) then + ! time_restart_current = esmf2fms_time(currTime) + ! timestamp = date_to_string(time_restart_current) + ! call ESMF_LogWrite("MOM: Writing restart at "//trim(timestamp), ESMF_LOGMSG_INFO, rc=rc) + ! write(*,*) 'calling ocean_model_restart' + ! call ocean_model_restart(ocean_state, timestamp) + ! endif + ! endif + + ! write restart file(s) + call ocean_model_restart(ocean_state, restartname=restartname) + + if (is_root_pe()) then + write(logunit,*) subname//' writing restart file ',trim(restartname) endif ! TODO: address if this requirement is being met for the DA group @@ -1863,10 +1531,7 @@ subroutine ModelAdvance(gcomp, rc) if (write_diagnostics) then call NUOPC_Write(exportState, fileNamePrefix='field_ocn_export_', & overwrite=overwrite_timeslice,timeslice=export_slice, relaxedFlag=.true., rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return export_slice = export_slice + 1 endif @@ -1899,22 +1564,13 @@ subroutine ModelSetRunClock(gcomp, rc) ! query the Component for its clock, importState and exportState call NUOPC_ModelGet(gcomp, driverClock=dclock, modelClock=mclock, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return call ESMF_ClockGet(dclock, currTime=dcurrtime, timeStep=dtimestep, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return call ESMF_ClockGet(mclock, currTime=mcurrtime, timeStep=mtimestep, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return !-------------------------------- ! check that the current time in the model and driver are the same @@ -1922,17 +1578,9 @@ subroutine ModelSetRunClock(gcomp, rc) if (mcurrtime /= dcurrtime) then call ESMF_TimeGet(dcurrtime, timeString=dtimestring, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return call ESMF_TimeGet(mcurrtime, timeString=mtimestring, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return call ESMF_LogSetError(ESMF_RC_VAL_WRONG, & msg=subname//": ERROR in time consistency: "//trim(dtimestring)//" != "//trim(mtimestring), & line=__LINE__, file=__FILE__, rcToReturn=rc) @@ -1946,49 +1594,47 @@ subroutine ModelSetRunClock(gcomp, rc) mstoptime = mcurrtime + dtimestep call ESMF_ClockSet(mclock, currTime=dcurrtime, timeStep=dtimestep, stopTime=mstoptime, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return if (first_time) then !-------------------------------- ! set restart alarm !-------------------------------- - ! defaults + ! set ddefaults restart_n = 0 restart_ymd = 0 - call NUOPC_CompAttributeGet(gcomp, name="restart_option", isPresent=isPresent, & - isSet=isSet, value=restart_option, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + call NUOPC_CompAttributeGet(gcomp, name="restart_option", value=restart_option, & + isPresent=isPresent, isSet=isSet, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + + ! If restart_option is set then must also have set either restart_n or restart_ymd if (isPresent .and. isSet) then - call NUOPC_CompAttributeGet(gcomp, name="restart_n", value=cvalue, & + call NUOPC_CompAttributeGet(gcomp, name="restart_n", value=cvalue, & isPresent=isPresent, isSet=isSet, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return if (isPresent .and. isSet) then read(cvalue,*) restart_n endif call NUOPC_CompAttributeGet(gcomp, name="restart_ymd", value=cvalue, & isPresent=isPresent, isSet=isSet, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return if (isPresent .and. isSet) then read(cvalue,*) restart_ymd endif + if (restart_n == 0 .and. restart_ymd == 0) then + call ESMF_LogSetError(ESMF_RC_VAL_WRONG, & + msg=subname//": ERROR both restart_n and restart_ymd are zero for restart_option set ", & + line=__LINE__, file=__FILE__, rcToReturn=rc) + return + end if else restart_option = "none" endif + call ESMF_LogWrite(subname//" Set restart option = "//restart_option, ESMF_LOGMSG_INFO) + ! initialize restart alarm call AlarmInit(mclock, & alarm = restart_alarm, & option = trim(restart_option), & @@ -1996,25 +1642,12 @@ subroutine ModelSetRunClock(gcomp, rc) opt_ymd = restart_ymd, & RefTime = mcurrTime, & alarmname = 'alarm_restart', rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return call ESMF_AlarmSet(restart_alarm, clock=mclock, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - first_time = .false. - - call ESMF_LogWrite(subname//" Set restart option = "//restart_option, & - ESMF_LOGMSG_INFO, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + first_time = .false. endif !-------------------------------- @@ -2022,16 +1655,10 @@ subroutine ModelSetRunClock(gcomp, rc) !-------------------------------- call ESMF_ClockAdvance(mclock,rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return call ESMF_ClockSet(mclock, currTime=dcurrtime, timeStep=dtimestep, stopTime=mstoptime, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return end subroutine ModelSetRunClock @@ -2162,58 +1789,37 @@ subroutine MOM_RealizeFields(state, nfields, field_defs, tag, grid, mesh, rc) if (field_defs(i)%shortname == scalar_field_name) then - call ESMF_LogWrite(subname // tag // " Field "// trim(field_defs(i)%stdname) // " is connected on root pe.", & - ESMF_LOGMSG_INFO, & - line=__LINE__, & - file=__FILE__, & - rc=rc) + call ESMF_LogWrite(subname//tag//" Field "//trim(field_defs(i)%stdname)//" is connected on root pe.", & + ESMF_LOGMSG_INFO) call SetScalarField(field, rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return else call ESMF_LogWrite(subname // tag // " Field "// trim(field_defs(i)%stdname) // " is connected.", & - ESMF_LOGMSG_INFO, & - line=__LINE__, & - file=__FILE__, & - rc=rc) + ESMF_LOGMSG_INFO) if (present(grid)) then field = ESMF_FieldCreate(grid, ESMF_TYPEKIND_R8, indexflag=ESMF_INDEX_DELOCAL, & name=field_defs(i)%shortname, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return ! initialize fldptr to zero call ESMF_FieldGet(field, farrayPtr=fldptr2d, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return fldptr2d(:,:) = 0.0 else if (present(mesh)) then field = ESMF_FieldCreate(mesh=mesh, typekind=ESMF_TYPEKIND_R8, meshloc=ESMF_MESHLOC_ELEMENT, & name=field_defs(i)%shortname, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return ! initialize fldptr to zero call ESMF_FieldGet(field, farrayPtr=fldptr1d, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return fldptr1d(:) = 0.0 endif @@ -2222,24 +1828,16 @@ subroutine MOM_RealizeFields(state, nfields, field_defs, tag, grid, mesh, rc) ! Realize connected field call NUOPC_Realize(state, field=field, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return else ! field is not connected call ESMF_LogWrite(subname // tag // " Field "// trim(field_defs(i)%stdname) // " is not connected.", & - ESMF_LOGMSG_INFO, & - line=__LINE__, & - file=__FILE__, & - rc=rc) + ESMF_LOGMSG_INFO) + ! remove a not connected Field from State call ESMF_StateRemove(state, (/field_defs(i)%shortname/), rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return endif From 81974e1f3b4fa1a92eab3c6c5acd459fd7ab5863 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Tue, 24 Mar 2020 11:53:09 -0400 Subject: [PATCH 121/316] +Changed units of forcing%ice_shelf_melt Changed the units of forcing%ice_shelf_melt to [R Z T-1 ~> kg m-2 s-1] and removed some unused variables. Diagnostics based on forcing%ice_shelf_melt have been rescaled so they retain their old units and values. All answers in MOM6-examples test cases are bitwise identical, including the ISOMIP test case. --- src/core/MOM_forcing_type.F90 | 2 +- src/ice_shelf/MOM_ice_shelf.F90 | 21 +++++++++------------ src/tracer/ISOMIP_tracer.F90 | 4 ++-- 3 files changed, 12 insertions(+), 15 deletions(-) diff --git a/src/core/MOM_forcing_type.F90 b/src/core/MOM_forcing_type.F90 index ebafa1d47a..b7260c2da6 100644 --- a/src/core/MOM_forcing_type.F90 +++ b/src/core/MOM_forcing_type.F90 @@ -149,7 +149,7 @@ module MOM_forcing_type !! associated if ice shelves are enabled, and are !! exactly 0 away from shelves or on land. real, pointer, dimension(:,:) :: iceshelf_melt => NULL() !< Ice shelf melt rate (positive) - !! or freezing (negative) [Z year-1 ~> m year-1] + !! or freezing (negative) [R Z T-1 ~> kg m-2 s-1] ! Scalars set by surface forcing modules real :: vPrecGlobalAdj = 0. !< adjustment to restoring vprec to zero out global net [kg m-2 s-1] diff --git a/src/ice_shelf/MOM_ice_shelf.F90 b/src/ice_shelf/MOM_ice_shelf.F90 index 62d00e283b..848c8ff06b 100644 --- a/src/ice_shelf/MOM_ice_shelf.F90 +++ b/src/ice_shelf/MOM_ice_shelf.F90 @@ -279,7 +279,6 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) real, parameter :: c2_3 = 2.0/3.0 character(len=160) :: mesg ! The text of an error message 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.") @@ -594,12 +593,7 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) enddo ! j-loop ! ISS%water_flux = net liquid water into the ocean [R Z T-1 ~> kg m-2 s-1] - ! We want melt in m/year - if (CS%const_gamma) then ! use ISOMIP+ eq. with rho_fw - fluxes%iceshelf_melt = ISS%water_flux * (86400.0*365.0*US%s_to_T/rho_fw) * CS%flux_factor - else ! use original eq. - fluxes%iceshelf_melt = ISS%water_flux * (86400.0*365.0*US%s_to_T/CS%density_ice) * CS%flux_factor - endif + fluxes%iceshelf_melt(:,:) = ISS%water_flux(:,:) * CS%flux_factor do j=js,je ; do i=is,ie if ((iDens*state%ocean_mass(i,j) > CS%col_thick_melt_threshold) .and. & @@ -907,8 +901,6 @@ subroutine add_shelf_flux(G, US, CS, state, fluxes) 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 [m5 kg-1 s-1] - real :: rho_fw = 1000.0 ! Fresh water density [R ~> kg m-3] character(len=160) :: mesg ! The text of an error message integer :: i, j, is, ie, js, je, isd, ied, jsd, jed is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec @@ -920,7 +912,6 @@ subroutine add_shelf_flux(G, US, CS, state, fluxes) ISS => CS%ISS - rho_fw = 1000.0*US%kg_m3_to_R ! fresh water density call add_shelf_pressure(G, US, CS, fluxes) @@ -1049,7 +1040,6 @@ subroutine add_shelf_flux(G, US, CS, state, fluxes) 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)) ! write(mesg,*) 'delta_mass_shelf = ', delta_mass_shelf ! call MOM_mesg(mesg,5) else! first time step @@ -1114,6 +1104,7 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl ! a restart file to the internal representation in this run. real :: L_rescale ! A rescaling factor for horizontal lengths from the representation in ! a restart file to the internal representation in this run. + real :: meltrate_conversion ! The conversion factor to use for in the melt rate diagnostic. real :: cdrag, drag_bg_vel logical :: new_sim, save_IC, var_force !This include declares and sets the variable "version". @@ -1596,8 +1587,14 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl 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', conversion=US%RZ_T_to_kg_m2s*US%L_to_m**2) + + if (CS%const_gamma) then ! use ISOMIP+ eq. with rho_fw = 1000. kg m-3 + meltrate_conversion = 86400.0*365.0*US%Z_to_m*US%s_to_T / (1000.0*US%kg_m3_to_R) + else ! use original eq. + meltrate_conversion = 86400.0*365.0*US%Z_to_m*US%s_to_T / CS%density_ice + endif CS%id_melt = register_diag_field('ocean_model', 'melt', CS%diag%axesT1, CS%Time, & - 'Ice Shelf Melt Rate', 'm yr-1', conversion=US%Z_to_m) + 'Ice Shelf Melt Rate', 'm yr-1', conversion= meltrate_conversion) CS%id_thermal_driving = register_diag_field('ocean_model', 'thermal_driving', CS%diag%axesT1, CS%Time, & 'pot. temp. in the boundary layer minus freezing pot. temp. at the ice-ocean interface.', 'Celsius') CS%id_haline_driving = register_diag_field('ocean_model', 'haline_driving', CS%diag%axesT1, CS%Time, & diff --git a/src/tracer/ISOMIP_tracer.F90 b/src/tracer/ISOMIP_tracer.F90 index a711437191..95d451791e 100644 --- a/src/tracer/ISOMIP_tracer.F90 +++ b/src/tracer/ISOMIP_tracer.F90 @@ -279,8 +279,8 @@ subroutine ISOMIP_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, G real :: b1(SZI_(G)) ! b1 and c1 are variables used by the real :: c1(SZI_(G),SZK_(G)) ! tridiagonal solver. real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: h_work ! Used so that h can be modified - real :: melt(SZI_(G),SZJ_(G)) ! melt water (positive for melting, negative for freezing) [Z year-1 ~> m year-1] - real :: mmax ! The global maximum melting rate [Z year-1 ~> m year-1] + real :: melt(SZI_(G),SZJ_(G)) ! melt water (positive for melting, negative for freezing) [R Z T-1 ~> kg m-2 s-1] + real :: mmax ! The global maximum melting rate [R Z T-1 ~> kg m-2 s-1] character(len=256) :: mesg ! The text of an error message integer :: i, j, k, is, ie, js, je, nz, m is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke From f3177f447565cf9188d9b4a32469645c1db89e28 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Tue, 24 Mar 2020 16:18:24 -0400 Subject: [PATCH 122/316] +Rescaled lengths in MOM_ice_shelf_dynamics.F90 Added dimensional rescaling of horizontal lengths in many variables in MOM_ice_shelf_dynamics.F90 and added comments describing many of the variables and their units. Some unused variables were eliminated, and other internal variables were renamed (e.g., u became u_shlf) for greater clarity and to ensure that all instances variables were properly rescaled. As a part of this change, the units of the ocean_mass argument to update_ice_shelf were changed. All answers in MOM6-examples test cases are bitwise identical, but it should be noted that there are no active tests of the ice shelf dynamics code. --- src/ice_shelf/MOM_ice_shelf.F90 | 3 +- src/ice_shelf/MOM_ice_shelf_dynamics.F90 | 1036 ++++++++++---------- src/ice_shelf/MOM_ice_shelf_initialize.F90 | 24 +- 3 files changed, 537 insertions(+), 526 deletions(-) diff --git a/src/ice_shelf/MOM_ice_shelf.F90 b/src/ice_shelf/MOM_ice_shelf.F90 index 848c8ff06b..8299d954b2 100644 --- a/src/ice_shelf/MOM_ice_shelf.F90 +++ b/src/ice_shelf/MOM_ice_shelf.F90 @@ -665,7 +665,8 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) ! 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, US, time_step, Time, state%ocean_mass, coupled_GL) + call update_ice_shelf(CS%dCS, ISS, G, US, time_step, Time, & + US%kg_m3_to_R*US%m_to_Z*state%ocean_mass(:,:), coupled_GL) endif diff --git a/src/ice_shelf/MOM_ice_shelf_dynamics.F90 b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 index e8d6f9b3c1..0fc319c621 100644 --- a/src/ice_shelf/MOM_ice_shelf_dynamics.F90 +++ b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 @@ -40,9 +40,9 @@ module MOM_ice_shelf_dynamics !> 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 - !! on q-points (B grid) [m s-1]?? + !! on q-points (B grid) [L yr-1 ~> m yr-1] real, pointer, dimension(:,:) :: v_shelf => NULL() !< the meridional velocity of the ice shelf/sheet - !! on q-points (B grid) [m s-1]?? + !! on q-points (B grid) [L yr-1 ~> m yr-1] real, pointer, dimension(:,:) :: u_face_mask => NULL() !< mask for velocity boundary conditions on the C-grid !! u-face - this is because the FEM cares about FACES THAT GET INTEGRATED OVER, @@ -56,10 +56,10 @@ module MOM_ice_shelf_dynamics !! v-face, with valued defined similarly to u_face_mask. real, pointer, dimension(:,:) :: u_face_mask_bdry => NULL() !< A duplicate copy of u_face_mask? real, pointer, dimension(:,:) :: v_face_mask_bdry => NULL() !< A duplicate copy of v_face_mask? - real, pointer, dimension(:,:) :: u_flux_bdry_val => NULL() !< The ice volume flux into the cell through open boundary - !! u-faces (where u_face_mask=4) [Z m2 s-1 ~> m3 s-1]?? - real, pointer, dimension(:,:) :: v_flux_bdry_val => NULL() !< The ice volume flux into the cell through open boundary - !! v-faces (where v_face_mask=4) [Z m2 s-1 ~> m3 s-1]?? + real, pointer, dimension(:,:) :: u_flux_bdry_val => NULL() !< The ice volume flux per unit face length into the cell + !! through open boundary u-faces (where u_face_mask=4) [Z L s-1 ~> m2 s-1] + real, pointer, dimension(:,:) :: v_flux_bdry_val => NULL() !< The ice volume flux per unit face length into the cell + !! through open boundary v-faces (where v_face_mask=4) [Z L s-1 ~> m2 s-1]?? ! needed where u_face_mask is equal to 4, similary for v_face_mask real, pointer, dimension(:,:) :: umask => NULL() !< u-mask on the actual degrees of freedom (B grid) !! 1=normal node, 3=inhomogeneous boundary node, @@ -74,12 +74,15 @@ module MOM_ice_shelf_dynamics real, pointer, dimension(:,:) :: tmask => NULL() !< A mask on tracer points that is 1 where there is ice. real, pointer, dimension(:,:) :: ice_visc => NULL() !< Glen's law ice viscosity, perhaps in [m]. real, pointer, dimension(:,:) :: thickness_bdry_val => NULL() !< The ice thickness at an inflowing boundary [Z ~> m]. - real, pointer, dimension(:,:) :: u_bdry_val => NULL() !< The zonal ice velocity at inflowing boundaries [m s-1]?? - real, pointer, dimension(:,:) :: v_bdry_val => NULL() !< The meridional ice velocity at inflowing boundaries [m s-1]?? + real, pointer, dimension(:,:) :: u_bdry_val => NULL() !< The zonal ice velocity at inflowing boundaries + !! [L yr-1 ~> m yr-1] + real, pointer, dimension(:,:) :: v_bdry_val => NULL() !< The meridional ice velocity at inflowing boundaries + !! [L yr-1 ~> m yr-1] real, pointer, dimension(:,:) :: h_bdry_val => NULL() !< The ice thickness at inflowing boundaries [m]. real, pointer, dimension(:,:) :: t_bdry_val => NULL() !< The ice temperature at inflowing boundaries [degC]. real, pointer, dimension(:,:) :: taub_beta_eff => NULL() !< nonlinear part of "linearized" basal stress. + !! [L-2 ? ~> m-2 ?] !! The exact form depends on basal law exponent and/or whether flow is "hybridized" a la Goldberg 2011 real, pointer, dimension(:,:) :: OD_rt => NULL() !< A running total for calculating OD_av. @@ -98,8 +101,8 @@ module MOM_ice_shelf_dynamics ! meaning if it is done too frequently. real :: elapsed_velocity_time !< The elapsed time since the ice velocies were last udated [s]. - real :: g_Earth !< The gravitational acceleration [m s-2]. - real :: density_ice !< A typical density of ice [kg m-3]. + real :: g_Earth !< The gravitational acceleration [L2 Z-1 T-2 ~> m s-2]. + real :: density_ice !< A typical density of ice [R ~> kg m-3]. logical :: GL_regularize !< Specifies whether to regularize the floatation condition !! at the grounding line as in Goldberg Holland Schoof 2009 @@ -116,16 +119,16 @@ module MOM_ice_shelf_dynamics 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 !< Ice viscosity parameter in Glen's Lawa, [Pa-1/3 year]. + real :: A_glen_isothermal !< Ice viscosity parameter in Glen's Law, [Pa-1/3 year]. real :: n_glen !< Nonlinearity exponent in Glen's Law real :: eps_glen_min !< Min. strain rate to avoid infinite Glen's law viscosity, [year-1]. real :: C_basal_friction !< Ceofficient in sliding law tau_b = C u^(n_basal_friction), in !! units="Pa (m-a)-(n_basal_friction) real :: n_basal_friction !< Exponent in sliding law tau_b = C u^(m_slide) - real :: density_ocean_avg !< This does not affect ocean circulation or thermodynamics. - !! It is used to estimate the gravitational driving force at the - !! shelf front (until we think of a better way to do it, - !! but any difference will be negligible). + real :: density_ocean_avg !< A typical ocean density [R ~> kg m-3]. This does not affect ocean + !! circulation or thermodynamics. It is used to estimate the + !! gravitational driving force at the shelf front (until we think of + !! 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 !< Specify whether to advance shelf front (and calve). logical :: calve_to_mask !< If true, calve off the ice shelf when it passes the edge of a mask. @@ -162,11 +165,12 @@ module MOM_ice_shelf_dynamics contains !> used for flux limiting in advective subroutines Van Leer limiter (source: Wikipedia) +!! The return value is between 0 and 2 [nondim]. 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 + real :: slope_limiter ! The slope limiter value, between 0 and 2 [nondim]. + real :: r ! The ratio of num/denom [nondim] if (denom == 0) then slope_limiter = 0 @@ -181,9 +185,10 @@ 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 + real, dimension(4), intent(in) :: X !< The x-positions of the vertices of the quadrilateral [L ~> m]. + real, dimension(4), intent(in) :: Y !< The y-positions of the vertices of the quadrilateral [L ~> m]. + real :: quad_area ! Computed area [L2 ~> m2] + real :: p2, q2, a2, c2, b2, d2 ! X and Y must be passed in the form ! 3 - 4 @@ -267,7 +272,7 @@ subroutine initialize_ice_shelf_dyn(param_file, Time, ISS, CS, G, US, diag, new_ !! 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(unit_scale_type), intent(in) :: US !< Pointer to a structure containing unit conversion factors + type(unit_scale_type), intent(in) :: US !< A structure containing unit conversion factors 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. @@ -277,6 +282,8 @@ subroutine initialize_ice_shelf_dyn(param_file, Time, ISS, CS, G, US, diag, new_ ! Local variables real :: Z_rescale ! A rescaling factor for heights from the representation in ! a restart file to the internal representation in this run. + real :: L_rescale ! A rescaling factor for horizontal lenghts from the representation in + ! a restart file to the internal representation in this run. !This include declares and sets the variable "version". # include "version_variable.h" character(len=200) :: config @@ -342,14 +349,14 @@ subroutine initialize_ice_shelf_dyn(param_file, Time, ISS, CS, G, US, diag, new_ 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.) + units="kg m-3", default=1035., scale=US%kg_m3_to_R) 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) + units="m s-2", default = 9.80, scale=US%m_s_to_L_T**2*US%Z_to_m) call get_param(param_file, mdl, "A_GLEN_ISOTHERM", CS%A_glen_isothermal, & "Ice viscosity parameter in Glen's Law", & @@ -367,7 +374,7 @@ subroutine initialize_ice_shelf_dyn(param_file, Time, ISS, CS, G, US, diag, new_ "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) + "A typical density of ice.", units="kg m-3", default=917.0, scale=US%kg_m3_to_R) call get_param(param_file, mdl, "CONJUGATE_GRADIENT_TOLERANCE", CS%cg_tolerance, & "tolerance in CG solver, relative to initial residual", default=1.e-6) call get_param(param_file, mdl, "ICE_NONLINEAR_TOLERANCE", CS%nonlinear_tolerance, & @@ -440,12 +447,21 @@ subroutine initialize_ice_shelf_dyn(param_file, Time, ISS, CS, G, US, diag, new_ enddo ; enddo endif + if ((US%m_to_L_restart /= 0.0) .and. (US%m_to_L_restart /= US%m_to_L)) then + L_rescale = US%m_to_L / US%m_to_L_restart + do J=G%jsc-1,G%jec ; do I=G%isc-1,G%iec + CS%u_shelf(I,J) = L_rescale * CS%u_shelf(I,J) + CS%v_shelf(I,J) = L_rescale * CS%v_shelf(I,J) + enddo ; enddo + endif + ! 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 + !### What about v_shelf? 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) @@ -498,15 +514,15 @@ subroutine initialize_ice_shelf_dyn(param_file, Time, ISS, CS, G, US, diag, new_ call update_OD_ffrac_uncoupled(CS, G, ISS%h_shelf(:,:)) call ice_shelf_solve_outer(CS, ISS, G, US, 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) + 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') + 'x-velocity of ice', 'm yr-1', conversion=US%L_to_m) CS%id_v_shelf = register_diag_field('ocean_model','v_shelf',CS%diag%axesCv1, Time, & - 'y-velocity of ice', 'm yr-1') + 'y-velocity of ice', 'm yr-1', conversion=US%L_to_m) 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, & @@ -541,7 +557,7 @@ subroutine initialize_diagnostic_fields(CS, ISS, G, US, Time) 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(unit_scale_type), intent(in) :: US !< Pointer to a structure containing unit conversion factors + type(unit_scale_type), intent(in) :: US !< A structure containing unit conversion factors type(time_type), intent(in) :: Time !< The current model time integer :: i, j, iters, isd, ied, jsd, jed @@ -579,20 +595,21 @@ function ice_time_step_CFL(CS, ISS, G) type(ocean_grid_type), intent(inout) :: G !< The grid structure used by the ice shelf. real :: ice_time_step_CFL !< The maximum permitted timestep based on the ice velocities [s]. - real :: ratio, min_ratio - real :: local_u_max, local_v_max + real :: ratio, min_ratio ! These should be the minimum stable timesteps at a CFL of 1 [years] + real :: local_u_max, local_v_max ! The largest neighboring velocities [L yr-1 ~> m yr-1] integer :: i, j - min_ratio = 1.0e16 ! This is just an arbitrary large nondiensional value. + min_ratio = 1.0e16 ! This is just an arbitrary large nondimensional 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))) - ! Here the hard-coded 1e-12 has units of m s-1. Consider revising. - ratio = G%US%L_to_m**2*min(G%areaT(i,j) / (local_u_max + 1.0e-12), & - G%areaT(i,j) / (local_v_max + 1.0e-12)) + ! Here the hard-coded 1e-12 has units of m year-1. Consider revising. + !### Ratio should be a timestep in {s] or [yr], but this expression appears to be in [m yr] + ratio = G%US%L_to_m*min(G%areaT(i,j) / (local_u_max + 1.0e-12*G%US%m_to_L), & + G%areaT(i,j) / (local_v_max + 1.0e-12*G%US%m_to_L)) min_ratio = min(min_ratio, ratio) endif ; enddo ; enddo ! i- and j- loops @@ -610,12 +627,12 @@ subroutine update_ice_shelf(CS, ISS, G, US, time_step, Time, ocean_mass, coupled 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. - type(unit_scale_type), intent(in) :: US !< Pointer to a structure containing unit conversion factors + type(unit_scale_type), intent(in) :: US !< A structure containing unit conversion factors real, intent(in) :: time_step !< time step [s] 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 per unit area - !! of the ocean [kg m-2]. + !! of the ocean [R Z ~> 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. @@ -648,8 +665,8 @@ subroutine update_ice_shelf(CS, ISS, G, US, time_step, Time, ocean_mass, coupled 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_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_ground_frac > 0) call post_data(CS%id_ground_frac, CS%ground_frac,CS%diag) if (CS%id_OD_av >0) call post_data(CS%id_OD_av, CS%OD_av,CS%diag) @@ -709,11 +726,11 @@ subroutine ice_shelf_advect(CS, ISS, G, time_step, Time) ! real, dimension(SZDI_(G),SZDJ_(G)) :: h_after_uflux, h_after_vflux ! Ice thicknesses [Z ~> m]. - real, dimension(SZDI_(G),SZDJ_(G),4) :: flux_enter + real, dimension(SZDI_(G),SZDJ_(G),4) :: flux_enter ! The ice volume flux into the cell + ! through the 4 cell boundaries [Z L2 ~> m3]. integer :: isd, ied, jsd, jed, i, j, isc, iec, jsc, jec - real :: rho, spy + real :: spy - 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 @@ -769,22 +786,25 @@ subroutine ice_shelf_advect(CS, ISS, G, time_step, Time) end subroutine ice_shelf_advect -subroutine ice_shelf_solve_outer(CS, ISS, G, US, u, v, iters, time) +subroutine ice_shelf_solve_outer(CS, ISS, G, US, u_shlf, v_shlf, 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. - type(unit_scale_type), intent(in) :: US !< Pointer to a structure containing unit conversion factors + type(unit_scale_type), intent(in) :: US !< A structure containing unit conversion factors real, dimension(SZDIB_(G),SZDJB_(G)), & - intent(inout) :: u !< The zonal ice shelf velocity at vertices [m year-1] + intent(inout) :: u_shlf !< The zonal ice shelf velocity at vertices [L yr-1 ~> m yr-1] real, dimension(SZDIB_(G),SZDJB_(G)), & - intent(inout) :: v !< The meridional ice shelf velocity at vertices [m year-1] + intent(inout) :: v_shlf !< The meridional ice shelf velocity at vertices [L yr-1 ~> m yr-1] 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 + real, dimension(SZDIB_(G),SZDJB_(G)) :: TAUDX, TAUDY ! Driving stresses at q-points [kg L s-2 ~> kg m s-2] + ! The units should be [R L3 Z T-2 ~> kg m s-2] + real, dimension(SZDIB_(G),SZDJB_(G)) :: u_bdry_cont, v_bdry_cont ! Boundary velocity contributions [L yr-1 ~> m yr-1] + real, dimension(SZDIB_(G),SZDJB_(G)) :: Au, Av ! A term in the momentum balance [L ? ~> m ?] + real, dimension(SZDIB_(G),SZDJB_(G)) :: err_u, err_v + real, dimension(SZDIB_(G),SZDJB_(G)) :: u_last, v_last ! Previous velocities [L yr-1 ~> m yr-1] real, dimension(SZDIB_(G),SZDJB_(G)) :: H_node ! Ice shelf thickness at corners [Z ~> m]. real, dimension(SZDI_(G),SZDJ_(G)) :: float_cond ! An array indicating where the ice ! shelf is floating: 0 if floating, 1 if not. @@ -792,14 +812,17 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u, v, iters, time) 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 + real, pointer, dimension(:,:,:,:) :: Phi => NULL() ! The gradients of bilinear basis elements at Gaussian + ! quadrature points surrounding the cell verticies [m-1]. + real, pointer, dimension(:,:,:,:,:,:) :: Phisub => NULL() ! Quadrature structure weights at subgridscale + ! locations for finite element calculations [nondim] + real, dimension(8,4) :: Phi_temp ! The gradients of bilinear basis elements at Gaussian + ! quadrature points surrounding a cell vertex [L-1 ~> m-1]. + real, dimension(2,2) :: X, Y ! Positions on cell [L ~> m] character(2) :: iternum character(2) :: numproc - ! for GL interpolation - need to make this a readable parameter + ! for GL interpolation nsub = CS%n_sub_regularize isdq = G%isdB ; iedq = G%iedB ; jsdq = G%jsdB ; jedq = G%jedB @@ -811,8 +834,8 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u, v, iters, time) 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 + float_cond(:,:) = 0.0 ; H_node(:,:) = 0.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. @@ -862,28 +885,25 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u, v, iters, time) ! make above conditional - u_prev_iterate(:,:) = u(:,:) - v_prev_iterate(:,:) = v(:,:) - - ! must prepare phi + ! 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 + X(:,:) = G%geoLonBu(i-1:i,j-1:j)*1000.0*US%m_to_L + Y(:,:) = G%geoLatBu(i-1:i,j-1:j)*1000.0*US%m_to_L else - X(2,:) = G%geoLonBu(i,j)*1000 - X(1,:) = G%geoLonBu(i,j)*1000 - US%L_to_m*G%dxT(i,j) - Y(:,2) = G%geoLatBu(i,j)*1000 - Y(:,1) = G%geoLatBu(i,j)*1000 - US%L_to_m*G%dyT(i,j) + X(2,:) = G%geoLonBu(i,j)*1000.0*US%m_to_L + X(1,:) = G%geoLonBu(i,j)*1000.0*US%m_to_L - G%dxT(i,j) + Y(:,2) = G%geoLatBu(i,j)*1000.0*US%m_to_L + Y(:,1) = G%geoLatBu(i,j)*1000.0*US%m_to_L - 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, US, u, v) + call calc_shelf_visc(CS, ISS, G, US, u_shlf, v_shlf) call pass_var(CS%ice_visc, G%domain) call pass_var(CS%taub_beta_eff, G%domain) @@ -894,24 +914,23 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u, v, iters, time) CS%taub_beta_eff(i,j) = CS%taub_beta_eff(i,j) * CS%ground_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) + call apply_boundary_values(CS, ISS, G, US, 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%US%L_to_m**2*G%areaT, & - G, G%isc-1, G%iec+1, G%jsc-1, G%jec+1, rhoi_rhow) + call CG_action(Au, Av, u_shlf, v_shlf, Phi, Phisub, CS%umask, CS%vmask, ISS%hmask, H_node, & + CS%ice_visc, float_cond, G%bathyT, CS%taub_beta_eff, G%areaT, & + G, US, 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)) + 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) + 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 @@ -921,27 +940,27 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u, v, iters, time) call max_across_PEs(err_init) - write(mesg,*) "ice_shelf_solve_outer: INITIAL nonlinear residual = ",err_init + write(mesg,*) "ice_shelf_solve_outer: INITIAL nonlinear residual = ", err_init*US%L_to_m call MOM_mesg(mesg, 5) - u_last(:,:) = u(:,:) ; v_last(:,:) = v(:,:) + u_last(:,:) = u_shlf(:,:) ; v_last(:,:) = v_shlf(:,:) !! begin loop do iter=1,100 - call ice_shelf_solve_inner(CS, ISS, G, u, v, TAUDX, TAUDY, H_node, float_cond, & + call ice_shelf_solve_inner(CS, ISS, G, US, u_shlf, v_shlf, 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) + call qchksum(u_shlf, "u shelf", G%HI, haloshift=2, scale=US%L_to_m) + call qchksum(v_shlf, "v shelf", G%HI, haloshift=2, scale=US%L_to_m) endif write(mesg,*) "ice_shelf_solve_outer: linear solve done in ",iters," iterations" call MOM_mesg(mesg, 5) - call calc_shelf_visc(CS, ISS, G, US, u, v) + call calc_shelf_visc(CS, ISS, G, US, u_shlf, v_shlf) call pass_var(CS%ice_visc, G%domain) call pass_var(CS%taub_beta_eff, G%domain) @@ -953,27 +972,27 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u, v, iters, time) u_bdry_cont(:,:) = 0 ; v_bdry_cont(:,:) = 0 - call apply_boundary_values(CS, ISS, G, time, Phisub, H_node, CS%ice_visc, & + call apply_boundary_values(CS, ISS, G, US, 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%US%L_to_m**2*G%areaT, & - G, G%isc-1, G%iec+1, G%jsc-1, G%jec+1, rhoi_rhow) + call CG_action(Au, Av, u_shlf, v_shlf, Phi, Phisub, CS%umask, CS%vmask, ISS%hmask, H_node, & + CS%ice_visc, float_cond, G%bathyT, CS%taub_beta_eff, G%areaT, & + G, US, 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 + 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)) + 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) + 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 @@ -990,12 +1009,12 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u, v, iters, time) 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) + err_tempu = ABS(u_last(i,j)-u_shlf(I,J)) + tempu = u_shlf(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) + err_tempv = MAX(ABS(v_last(i,j)-v_shlf(I,J)), err_tempu) + tempv = SQRT(v_shlf(I,J)**2 + tempu**2) endif if (err_tempv >= err_max) then err_max = err_tempv @@ -1006,8 +1025,8 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u, v, iters, time) enddo enddo - u_last(:,:) = u(:,:) - v_last(:,:) = v(:,:) + u_last(:,:) = u_shlf(:,:) + v_last(:,:) = v_shlf(:,:) call max_across_PEs(max_vel) call max_across_PEs(err_max) @@ -1015,7 +1034,7 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u, v, iters, time) endif - write(mesg,*) "ice_shelf_solve_outer: nonlinear residual = ",err_max/err_init + write(mesg,*) "ice_shelf_solve_outer: nonlinear residual = ", err_max/err_init call MOM_mesg(mesg, 5) if (err_max <= CS%nonlinear_tolerance * err_init) then @@ -1031,20 +1050,22 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u, v, iters, time) end subroutine ice_shelf_solve_outer -subroutine ice_shelf_solve_inner(CS, ISS, G, u, v, taudx, taudy, H_node, float_cond, & +subroutine ice_shelf_solve_inner(CS, ISS, G, US, u_shlf, v_shlf, 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. + type(unit_scale_type), intent(in) :: US !< A structure containing unit conversion factors real, dimension(SZDIB_(G),SZDJB_(G)), & - intent(inout) :: u !< The zonal ice shelf velocity at vertices [m year-1] + intent(inout) :: u_shlf !< The zonal ice shelf velocity at vertices [L yr-1 ~> m yr-1] real, dimension(SZDIB_(G),SZDJB_(G)), & - intent(inout) :: v !< The meridional ice shelf velocity at vertices [m year-1] + intent(inout) :: v_shlf !< The meridional ice shelf velocity at vertices [L yr-1 ~> m yr-1] real, dimension(SZDIB_(G),SZDJB_(G)), & - intent(in) :: taudx !< The x-direction driving stress, in ??? + intent(in) :: taudx !< The x-direction driving stress, in [kg L s-2 ~> kg m s-2] real, dimension(SZDIB_(G),SZDJB_(G)), & - intent(in) :: taudy !< The y-direction driving stress, in ??? + intent(in) :: taudy !< The y-direction driving stress, in [kg L s-2 ~> kg m s-2] + ! This will become [R L3 Z T-2 ~> kg m s-2] real, dimension(SZDIB_(G),SZDJB_(G)), & intent(in) :: H_node !< The ice shelf thickness at nodal (corner) !! points [Z ~> m]. @@ -1060,10 +1081,10 @@ subroutine ice_shelf_solve_inner(CS, ISS, G, u, v, taudx, taudy, H_node, float_c 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. + !! quadrature points surrounding the cell verticies [L-1 ~> m-1]. real, dimension(:,:,:,:,:,:), & intent(in) :: Phisub !< Quadrature structure weights at subgridscale - !! locations for finite element calculations + !! locations for finite element calculations [nondim] ! one linear solve (nonlinear iteration) of the solution for velocity ! in this subroutine: @@ -1074,18 +1095,24 @@ subroutine ice_shelf_solve_inner(CS, ISS, G, u, v, taudx, taudy, H_node, float_c ! 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, & + Ru, Rv, & ! Residuals in the stress calculations [L kg s-2 ~> m kg s-2] + Ru_old, Rv_old, & + Zu, Zv, & ! Contributions to velocity changes [L yr-1 ~> m yr-1]? + Zu_old, Zv_old, & ! Previous values of Zu and Zv [L yr-1 ~> m yr-1]? + DIAGu, DIAGv, & + RHSu, RHSv, & ! Right hand side of the stress balance [L kg s-2 ~> m kg s-2] + ubd, vbd, & ! Boundary stress contributions [L kg s-2 ~> m kg s-2] + Au, Av, & + Du, Dv, & ! Velocity changes [L yr-1 ~> m yr-1] sum_vec, sum_vec_2 - integer :: iter, i, j, isd, ied, jsd, jed, & + 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 :: tol, beta_k, alpha_k, area, dot_p1, dot_p2, resid0, cg_halo, dot_p1a, dot_p2a + real :: resid_scale ! A scaling factor for redimensionalizing the global residuals [m2 L-2 ~> 1] +! character(2) :: gridsize - real, dimension(8,4) :: Phi_temp - real, dimension(2,2) :: X,Y +! 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 @@ -1106,37 +1133,38 @@ subroutine ice_shelf_solve_inner(CS, ISS, G, u, v, taudx, taudy, H_node, float_c ! 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) + call apply_boundary_values(CS, ISS, G, US, 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, & + call matrix_diagonal(CS, G, US, 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%US%L_to_m**2*G%areaT, G, isc-1, iec+1, jsc-1, jec+1, CS%density_ice/CS%density_ocean_avg) + call CG_action(Au, Av, u_shlf, v_shlf, Phi, Phisub, CS%umask, CS%vmask, hmask, & + H_node, CS%ice_visc, float_cond, G%bathyT, CS%taub_beta_eff, & + G%areaT, G, US, 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(:,:) + resid_scale = US%L_to_m**2 + 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 + if (CS%umask(i,j) == 1) dot_p1 = dot_p1 + resid_scale*Ru(i,j)**2 + if (CS%vmask(i,j) == 1) dot_p1 = dot_p1 + resid_scale*Rv(i,j)**2 enddo enddo @@ -1148,8 +1176,8 @@ subroutine ice_shelf_solve_inner(CS, ISS, G, u, v, taudx, taudy, H_node, float_c 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 + if (CS%umask(i,j) == 1) sum_vec(i,j) = resid_scale*Ru(i,j)**2 + if (CS%vmask(i,j) == 1) sum_vec(i,j) = sum_vec(i,j) + resid_scale*Rv(i,j)**2 enddo enddo @@ -1195,8 +1223,8 @@ subroutine ice_shelf_solve_inner(CS, ISS, G, u, v, taudx, taudy, H_node, float_c 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%US%L_to_m**2*G%areaT, G, is, ie, js, je, CS%density_ice/CS%density_ocean_avg) + H_node, CS%ice_visc, float_cond, G%bathyT, CS%taub_beta_eff, & + G%areaT, G, US, is, ie, js, je, CS%density_ice/CS%density_ocean_avg) ! Au, Av valid region moves in by 1 @@ -1208,12 +1236,12 @@ subroutine ice_shelf_solve_inner(CS, ISS, G, u, v, taudx, taudy, H_node, float_c 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) + dot_p1 = dot_p1 + resid_scale*Zu(i,j)*Ru(i,j) + dot_p2 = dot_p2 + resid_scale*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) + dot_p1 = dot_p1 + resid_scale*Zv(i,j)*Rv(i,j) + dot_p2 = dot_p2 + resid_scale*Dv(i,j)*Av(i,j) endif enddo enddo @@ -1224,11 +1252,11 @@ subroutine ice_shelf_solve_inner(CS, ISS, G, u, v, taudx, taudy, H_node, float_c 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(i,j) = resid_scale*Zu(i,j) * Ru(i,j) + if (CS%vmask(i,j) == 1) sum_vec(i,j) = sum_vec(i,j) + resid_scale*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) + if (CS%umask(i,j) == 1) sum_vec_2(i,j) = resid_scale*Du(i,j) * Au(i,j) + if (CS%vmask(i,j) == 1) sum_vec_2(i,j) = sum_vec_2(i,j) + resid_scale*Dv(i,j) * Av(i,j) enddo enddo @@ -1243,8 +1271,8 @@ subroutine ice_shelf_solve_inner(CS, ISS, G, u, v, taudx, taudy, H_node, float_c 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) + if (CS%umask(i,j) == 1) u_shlf(I,J) = u_shlf(I,J) + alpha_k * Du(i,j) + if (CS%vmask(i,j) == 1) v_shlf(I,J) = v_shlf(I,J) + alpha_k * Dv(i,j) enddo enddo @@ -1290,12 +1318,12 @@ subroutine ice_shelf_solve_inner(CS, ISS, G, u, v, taudx, taudy, H_node, float_c 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) + dot_p1 = dot_p1 + resid_scale*Zu(i,j)*Ru(i,j) + dot_p2 = dot_p2 + resid_scale*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) + dot_p1 = dot_p1 + resid_scale*Zv(i,j)*Rv(i,j) + dot_p2 = dot_p2 + resid_scale*Zv_old(i,j)*Rv_old(i,j) endif enddo enddo @@ -1308,13 +1336,11 @@ subroutine ice_shelf_solve_inner(CS, ISS, G, u, v, taudx, taudy, H_node, float_c 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(i,j) = resid_scale*Zu(i,j) * Ru(i,j) + if (CS%vmask(i,j) == 1) sum_vec(i,j) = sum_vec(i,j) + resid_scale*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) + if (CS%umask(i,j) == 1) sum_vec_2(i,j) = resid_scale*Zu_old(i,j) * Ru_old(i,j) + if (CS%vmask(i,j) == 1) sum_vec_2(i,j) = sum_vec_2(i,j) + resid_scale*Zv_old(i,j) * Rv_old(i,j) enddo enddo @@ -1349,10 +1375,10 @@ subroutine ice_shelf_solve_inner(CS, ISS, G, u, v, taudx, taudy, H_node, float_c do j=jsumstart,jecq do i=isumstart,iecq if (CS%umask(i,j) == 1) then - dot_p1 = dot_p1 + Ru(i,j)**2 + dot_p1 = dot_p1 + resid_scale*Ru(i,j)**2 endif if (CS%vmask(i,j) == 1) then - dot_p1 = dot_p1 + Rv(i,j)**2 + dot_p1 = dot_p1 + resid_scale*Rv(i,j)**2 endif enddo enddo @@ -1364,8 +1390,8 @@ subroutine ice_shelf_solve_inner(CS, ISS, G, u, v, taudx, taudy, H_node, float_c 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 + if (CS%umask(i,j) == 1) sum_vec(i,j) = resid_scale*Ru(i,j)**2 + if (CS%vmask(i,j) == 1) sum_vec(i,j) = sum_vec(i,j) + resid_scale*Rv(i,j)**2 enddo enddo @@ -1386,7 +1412,7 @@ subroutine ice_shelf_solve_inner(CS, ISS, G, u, v, taudx, taudy, H_node, float_c 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(u_shlf, v_shlf, G%domain, TO_ALL, BGRID_NE) call pass_vector(Ru, Rv, G%domain, TO_ALL, BGRID_NE) cg_halo = 3 endif @@ -1396,20 +1422,20 @@ subroutine ice_shelf_solve_inner(CS, ISS, G, u, v, taudx, taudy, H_node, float_c do j=jsdq,jedq do i=isdq,iedq if (CS%umask(i,j) == 3) then - u(i,j) = CS%u_bdry_val(i,j) + u_shlf(I,J) = CS%u_bdry_val(i,j) elseif (CS%umask(i,j) == 0) then - u(i,j) = 0 + u_shlf(I,J) = 0 endif if (CS%vmask(i,j) == 3) then - v(i,j) = CS%v_bdry_val(i,j) + v_shlf(I,J) = CS%v_bdry_val(i,j) elseif (CS%vmask(i,j) == 0) then - v(i,j) = 0 + v_shlf(I,J) = 0 endif enddo enddo - call pass_vector(u,v, G%domain, TO_ALL, BGRID_NE) + call pass_vector(u_shlf, v_shlf, G%domain, TO_ALL, BGRID_NE) if (conv_flag == 0) then iters = CS%cg_max_iterations @@ -1431,7 +1457,7 @@ subroutine ice_shelf_advect_thickness_x(CS, G, time_step, hmask, h0, h_after_ufl !! the zonal mass fluxes [Z ~> m]. real, dimension(SZDI_(G),SZDJ_(G),4), & intent(inout) :: flux_enter !< The ice volume flux into the cell - !! through the 4 cell boundaries [Z m2 ~> m3]. + !! through the 4 cell boundaries [Z L2 ~> m3]. ! use will be made of ISS%hmask here - its value at the boundary will be zero, just like uncovered cells @@ -1455,8 +1481,9 @@ subroutine ice_shelf_advect_thickness_x(CS, G, time_step, hmask, h0, h_after_ufl 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 ! Thicknesses [Z ~> m]. - real :: u_face, & ! positive if out - flux_diff_cell, phi, dxh, dyh, dxdyh + real :: u_face ! Zonal velocity at a face, positive if out {L s-1 ~> m s-1] + real :: flux_diff_cell + real :: slope_lim ! The value of the slope limiter, in the range of 0 to 2 [nondim] character (len=1) :: debug_str is = G%isc-2 ; ie = G%iec+2 ; js = G%jsc ; je = G%jec @@ -1488,8 +1515,6 @@ subroutine ice_shelf_advect_thickness_x(CS, G, time_step, hmask, h0, h_after_ufl if (hmask(i,j) == 1) then - dxh = G%US%L_to_m*G%dxT(i,j) ; dyh = G%US%L_to_m*G%dyT(i,j) ; dxdyh = G%US%L_to_m**2*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 @@ -1500,7 +1525,7 @@ subroutine ice_shelf_advect_thickness_x(CS, G, time_step, hmask, h0, h_after_ufl 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 + flux_diff_cell = flux_diff_cell + G%dyT(i,j) * time_step * CS%u_flux_bdry_val(i-1,j) / G%areaT(i,j) else @@ -1514,32 +1539,32 @@ subroutine ice_shelf_advect_thickness_x(CS, G, time_step, hmask, h0, h_after_ufl 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 + flux_diff_cell = flux_diff_cell + ABS(u_face) * G%dyT(i,j) * time_step * stencil(-1) / G%areaT(i,j) 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) + slope_lim = slope_limiter(stencil(-1)-stencil(-2), stencil(0)-stencil(-1)) + flux_diff_cell = flux_diff_cell + ABS(u_face) * G%dyT(i,j)* time_step / G%areaT(i,j) * & + (stencil(-1) - slope_lim * (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) + flux_diff_cell = flux_diff_cell + ABS(u_face) * (G%dyT(i,j) * time_step / G%areaT(i,j)) * 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) + slope_lim = slope_limiter(stencil(0)-stencil(1), stencil(-1)-stencil(0)) + flux_diff_cell = flux_diff_cell - ABS(u_face) * G%dyT(i,j) * time_step / G%areaT(i,j) * & + (stencil(0) - slope_lim * (stencil(0)-stencil(-1))/2) else - flux_diff_cell = flux_diff_cell - ABS(u_face) * (dyh * time_step / dxdyh) * stencil(0) + flux_diff_cell = flux_diff_cell - ABS(u_face) * (G%dyT(i,j) * time_step / G%areaT(i,j)) * 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) + flux_enter(i-1,j,2) = ABS(u_face) * G%dyT(i,j) * time_step * stencil(0) endif endif endif @@ -1551,7 +1576,7 @@ subroutine ice_shelf_advect_thickness_x(CS, G, time_step, hmask, h0, h_after_ufl 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 + flux_diff_cell = flux_diff_cell + G%dyT(i,j) * time_step * CS%u_flux_bdry_val(i+1,j) / G%areaT(i,j) else @@ -1562,19 +1587,19 @@ subroutine ice_shelf_advect_thickness_x(CS, G, time_step, hmask, h0, h_after_ufl 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 + flux_diff_cell = flux_diff_cell + ABS(u_face) * G%dyT(i,j) * time_step * stencil(1) / G%areaT(i,j) 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) + slope_lim = slope_limiter(stencil(1)-stencil(2), stencil(0)-stencil(1)) + flux_diff_cell = flux_diff_cell + ABS(u_face) * G%dyT(i,j) * time_step / G%areaT(i,j) * & + (stencil(1) - slope_lim * (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) + flux_diff_cell = flux_diff_cell + ABS(u_face) * (G%dyT(i,j) * time_step / G%areaT(i,j)) * stencil(1) endif @@ -1582,18 +1607,18 @@ subroutine ice_shelf_advect_thickness_x(CS, G, time_step, hmask, h0, h_after_ufl 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) + slope_lim = slope_limiter(stencil(0)-stencil(-1), stencil(1)-stencil(0)) + flux_diff_cell = flux_diff_cell - ABS(u_face) * G%dyT(i,j) * time_step / G%areaT(i,j) * & + (stencil(0) - slope_lim * (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) + flux_diff_cell = flux_diff_cell - ABS(u_face) * (G%dyT(i,j) * time_step / G%areaT(i,j)) * 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) + flux_enter(i+1,j,1) = ABS(u_face) * G%dyT(i,j) * time_step * stencil(0) endif endif @@ -1608,16 +1633,16 @@ subroutine ice_shelf_advect_thickness_x(CS, G, time_step, hmask, h0, h_after_ufl 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%US%L_to_m*G%dyT(i,j) * time_step * CS%thickness_bdry_val(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%US%L_to_m*G%dyT(i,j) * time_step * CS%u_flux_bdry_val(i-1,j) + 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%US%L_to_m*G%dyT(i,j) * time_step * CS%thickness_bdry_val(i+1,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%US%L_to_m*G%dyT(i,j) * time_step * CS%u_flux_bdry_val(i+1,j) + 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 @@ -1662,7 +1687,7 @@ subroutine ice_shelf_advect_thickness_y(CS, G, time_step, hmask, h_after_uflux, !! the meridional mass fluxes [Z ~> m]. real, dimension(SZDI_(G),SZDJ_(G),4), & intent(inout) :: flux_enter !< The ice volume flux into the cell - !! through the 4 cell boundaries [Z m2 ~> m3]. + !! through the 4 cell boundaries [Z L2 ~> m3]. ! use will be made of ISS%hmask here - its value at the boundary will be zero, just like uncovered cells @@ -1686,8 +1711,9 @@ subroutine ice_shelf_advect_thickness_y(CS, G, time_step, hmask, h_after_uflux, 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 ! Thicknesses [Z ~> m]. - real :: v_face, & ! positive if out - flux_diff_cell, phi, dxh, dyh, dxdyh + real :: v_face ! Pseudo-meridional velocity at a cell face, positive if out {L s-1 ~> m s-1] + real :: flux_diff_cell + real :: slope_lim ! The value of the slope limiter, in the range of 0 to 2 [nondim] 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 @@ -1717,7 +1743,6 @@ subroutine ice_shelf_advect_thickness_y(CS, G, time_step, hmask, h_after_uflux, endif if (hmask(i,j) == 1) then - dxh = G%US%L_to_m*G%dxT(i,j) ; dyh = G%US%L_to_m*G%dyT(i,j) ; dxdyh = G%US%L_to_m**2*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 @@ -1727,7 +1752,7 @@ subroutine ice_shelf_advect_thickness_y(CS, G, time_step, hmask, h_after_uflux, 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 + flux_diff_cell = flux_diff_cell + G%dxT(i,j) * time_step * CS%v_flux_bdry_val(i,j-1) / G%areaT(i,j) else @@ -1740,31 +1765,32 @@ subroutine ice_shelf_advect_thickness_y(CS, G, time_step, hmask, h_after_uflux, 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 + flux_diff_cell = flux_diff_cell + ABS(v_face) * G%dxT(i,j) * time_step * stencil(-1) / G%areaT(i,j) 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) + slope_lim = slope_limiter(stencil(-1)-stencil(-2), stencil(0)-stencil(-1)) + flux_diff_cell = flux_diff_cell + ABS(v_face) * G%dxT(i,j) * time_step / G%areaT(i,j) * & + (stencil(-1) - slope_lim * (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) + flux_diff_cell = flux_diff_cell + ABS(v_face) * (G%dxT(i,j) * time_step / G%areaT(i,j)) * 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) + slope_lim = slope_limiter(stencil(0)-stencil(1), stencil(-1)-stencil(0)) + flux_diff_cell = flux_diff_cell - ABS(v_face) * G%dxT(i,j) * time_step / G%areaT(i,j) * & + (stencil(0) - slope_lim * (stencil(0)-stencil(-1))/2) else - flux_diff_cell = flux_diff_cell - ABS(v_face) * (dxh * time_step / dxdyh) * stencil(0) + flux_diff_cell = flux_diff_cell - ABS(v_face) * (G%dxT(i,j) * time_step / G%areaT(i,j)) * stencil(0) + !### The G%dyT in the next line needs to become G%dxCu(i,J-1) 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) + flux_enter(i,j-1,4) = ABS(v_face) * G%dyT(i,j) * time_step * stencil(0) endif endif @@ -1777,7 +1803,7 @@ subroutine ice_shelf_advect_thickness_y(CS, G, time_step, hmask, h_after_uflux, 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 + flux_diff_cell = flux_diff_cell + G%dxT(i,j) * time_step * CS%v_flux_bdry_val(i,j+1) / G%areaT(i,j) else @@ -1788,29 +1814,29 @@ subroutine ice_shelf_advect_thickness_y(CS, G, time_step, hmask, h_after_uflux, 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 + flux_diff_cell = flux_diff_cell + ABS(v_face) * G%dxT(i,j) * time_step * stencil(1) / G%areaT(i,j) 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) + slope_lim = slope_limiter(stencil(1)-stencil(2), stencil(0)-stencil(1)) + flux_diff_cell = flux_diff_cell + ABS(v_face) * G%dxT(i,j) * time_step / G%areaT(i,j) * & + (stencil(1) - slope_lim * (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) + flux_diff_cell = flux_diff_cell + ABS(v_face) * G%dxT(i,j) * time_step / G%areaT(i,j) * 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) + slope_lim = slope_limiter(stencil(0)-stencil(-1), stencil(1)-stencil(0)) + flux_diff_cell = flux_diff_cell - ABS(v_face) * G%dxT(i,j) * time_step / G%areaT(i,j) * & + (stencil(0) - slope_lim * (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) + flux_diff_cell = flux_diff_cell - ABS(v_face) * G%dxT(i,j) * time_step / G%areaT(i,j) * 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) + flux_enter(i,j+1,3) = ABS(v_face) * G%dxT(i,j) * time_step * stencil(0) endif endif @@ -1824,16 +1850,16 @@ subroutine ice_shelf_advect_thickness_y(CS, G, time_step, hmask, h_after_uflux, 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%US%L_to_m*G%dxT(i,j) * time_step * CS%thickness_bdry_val(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%US%L_to_m*G%dxT(i,j) * time_step * CS%v_flux_bdry_val(i,j-1) + 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%US%L_to_m*G%dxT(i,j) * time_step * CS%thickness_bdry_val(i,j+1) + 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%US%L_to_m*G%dxT(i,j) * time_step * CS%v_flux_bdry_val(i,j+1) + 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 @@ -1863,7 +1889,7 @@ subroutine shelf_advance_front(CS, ISS, G, flux_enter) 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 [Z m2 ~> m3]. + !! through the 4 cell boundaries [Z L2 ~> 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 @@ -1896,17 +1922,18 @@ subroutine shelf_advance_front(CS, ISS, G, flux_enter) integer :: i_off, j_off integer :: iter_flag - real :: h_reference, dxh, dyh, rho, tot_flux - real :: partial_vol ! The volume covered by ice shelf [m L2 ~> m3] + real :: h_reference ! A reference thicknesss based on neighboring cells [Z ~> m] + real :: tot_flux ! The total ice mass flux [Z L2 ~> m3] + real :: partial_vol ! The volume covered by ice shelf [Z L2 ~> m3] real :: dxdyh ! Cell area [L2 ~> m2] character(len=160) :: mesg ! The text of an error message 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 + real, dimension(SZDI_(G),SZDJ_(G),4) :: flux_enter_replace ! An updated ice volume flux into the + ! cell through the 4 cell boundaries [Z L2 ~> m3]. 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 @@ -1961,23 +1988,23 @@ subroutine shelf_advance_front(CS, ISS, G, flux_enter) 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) + G%US%m_to_L**2*tot_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 + if ((partial_vol / G%areaT(i,j)) == 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%area_shelf_h(i,j) = G%areaT(i,j) + elseif ((partial_vol / G%areaT(i,j)) < h_reference) then ISS%hmask(i,j) = 2 - ! ISS%mass_shelf(i,j) = G%US%L_to_Z*G%US%L_to_m*partial_vol * G%US%kg_m3_to_R*rho + ! ISS%mass_shelf(i,j) = partial_vol * CS%density_ice 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 + ISS%area_shelf_h(i,j) = G%areaT(i,j) !h_temp(i,j) = h_reference - partial_vol = partial_vol - h_reference * dxdyh + partial_vol = partial_vol - h_reference * G%areaT(i,j) iter_flag = 1 @@ -1999,15 +2026,15 @@ subroutine shelf_advance_front(CS, ISS, G, flux_enter) enddo if (n_flux == 0) then ! there is nowhere to put the extra ice! - ISS%h_shelf(i,j) = h_reference + partial_vol / dxdyh + ISS%h_shelf(i,j) = h_reference + partial_vol / G%areaT(i,j) 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) = G%US%L_to_m**2*partial_vol / real(n_flux) + flux_enter_replace(i+2*k-3,j,3-k) = partial_vol / real(n_flux) if (new_partial(k+2) == 1) & - flux_enter_replace(i,j+2*k-3,5-k) = G%US%L_to_m**2*partial_vol / real(n_flux) + flux_enter_replace(i,j+2*k-3,5-k) = partial_vol / real(n_flux) enddo endif @@ -2080,25 +2107,26 @@ subroutine calve_to_mask(G, h_shelf, area_shelf_h, hmask, calve_mask) end subroutine calve_to_mask -subroutine calc_shelf_driving_stress(CS, ISS, G, US, TAUD_X, TAUD_Y, OD) +subroutine calc_shelf_driving_stress(CS, ISS, G, US, 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. - type(unit_scale_type), intent(in) :: US !< Pointer to a structure containing unit conversion factors + type(unit_scale_type), intent(in) :: US !< A structure containing unit conversion factors real, dimension(SZDI_(G),SZDJ_(G)), & intent(in) :: OD !< ocean floor depth at tracer points [Z ~> m]. real, dimension(SZDIB_(G),SZDJB_(G)), & - intent(inout) :: TAUD_X !< X-direction driving stress at q-points + intent(inout) :: taud_x !< X-direction driving stress at q-points [kg L s-2 ~> kg m s-2] real, dimension(SZDIB_(G),SZDJB_(G)), & - intent(inout) :: TAUD_Y !< Y-direction driving stress at q-points + intent(inout) :: taud_y !< Y-direction driving stress at q-points [kg L s-2 ~> kg m s-2] + ! This will become [R L3 Z T-2 ~> kg m s-2] ! 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 +! 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 @@ -2108,7 +2136,13 @@ subroutine calc_shelf_driving_stress(CS, ISS, G, US, TAUD_X, TAUD_Y, OD) BASE ! basal elevation of shelf/stream [Z ~> m]. - real :: rho, rhow, sx, sy, neumann_val, dxh, dyh, dxdyh, grav + real :: rho, rhow ! Ice and ocean densities [R ~> kg m-3] + real :: sx, sy ! Ice shelf top slopes [Z L-1 ~> m s-1] + real :: neumann_val ! [R Z L2 T-2 ~> kg s-2] + real :: dxh, dyh ! Local grid spacing [L ~> m] + real :: grav ! The gravitational acceleration [L2 Z-1 T-2 ~> m s-2] + real :: taud_scale ! The conversion factor from scaled to MKS units for taud_x and + ! taud_y [kg s-2 R-1 L-2 Z-1 T2 ~> 1] integer :: i, j, iscq, iecq, jscq, jecq, isd, jsd, is, js, iegq, jegq integer :: giec, gjec, gisc, gjsc, cnt, isc, jsc, iec, jec @@ -2123,9 +2157,10 @@ subroutine calc_shelf_driving_stress(CS, ISS, G, US, TAUD_X, TAUD_Y, OD) is = iscq - 1; js = jscq - 1 i_off = G%idg_offset ; j_off = G%jdg_offset - rho = CS%density_ice + rho = CS%density_ice rhow = CS%density_ocean_avg - grav = US%Z_to_m**2 * CS%g_Earth + grav = CS%g_Earth + taud_scale = US%R_to_kg_m3*US%Z_to_m**US%L_T_to_m_s**2 ! prelim - go through and calculate S @@ -2138,9 +2173,8 @@ subroutine calc_shelf_driving_stress(CS, ISS, G, US, TAUD_X, TAUD_Y, OD) cnt = 0 sx = 0 sy = 0 - dxh = US%L_to_m*G%dxT(i,j) - dyh = US%L_to_m*G%dyT(i,j) - dxdyh = US%L_to_m**2*G%areaT(i,j) + dxh = G%dxT(i,j) + dyh = G%dyT(i,j) if (ISS%hmask(i,j) == 1) then ! we are inside the global computational bdry, at an ice-filled cell @@ -2213,20 +2247,20 @@ subroutine calc_shelf_driving_stress(CS, ISS, G, US, TAUD_X, TAUD_Y, OD) 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 + taud_x(I-1,J-1) = taud_x(I-1,J-1) - .25 * rho * taud_scale * grav * ISS%h_shelf(i,j) * sx * G%areaT(i,j) + taud_y(I-1,J-1) = taud_y(I-1,J-1) - .25 * rho * taud_scale * grav * ISS%h_shelf(i,j) * sy * G%areaT(i,j) ! 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 + taud_x(I,J-1) = taud_x(I,J-1) - .25 * rho * taud_scale * grav * ISS%h_shelf(i,j) * sx * G%areaT(i,j) + taud_y(I,J-1) = taud_y(I,J-1) - .25 * rho * taud_scale * grav * ISS%h_shelf(i,j) * sy * G%areaT(i,j) ! 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 + taud_x(I-1,J) = taud_x(I-1,J) - .25 * rho * taud_scale * grav * ISS%h_shelf(i,j) * sx * G%areaT(i,j) + taud_y(I-1,J) = taud_y(I-1,J) - .25 * rho * taud_scale * grav * ISS%h_shelf(i,j) * sy * G%areaT(i,j) ! 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 + taud_x(I,J) = taud_x(I,J) - .25 * rho * taud_scale * grav * ISS%h_shelf(i,j) * sx * G%areaT(i,j) + taud_y(I,J) = taud_y(I,J) - .25 * rho * taud_scale * grav * ISS%h_shelf(i,j) * sy * G%areaT(i,j) if (CS%ground_frac(i,j) == 1) then neumann_val = .5 * grav * (rho * ISS%h_shelf(i,j)**2 - rhow * G%bathyT(i,j)**2) @@ -2234,7 +2268,6 @@ subroutine calc_shelf_driving_stress(CS, ISS, G, US, TAUD_X, TAUD_Y, OD) 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 @@ -2244,27 +2277,27 @@ subroutine calc_shelf_driving_stress(CS, ISS, G, US, TAUD_X, TAUD_Y, OD) ! 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 + ! Note the negative sign due to the direction of the normal vector + taud_x(i-1,j-1) = taud_x(i-1,j-1) - .5 * taud_scale * dyh * neumann_val + taud_x(i-1,j) = taud_x(i-1,j) - .5 * taud_scale * 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 + taud_x(i,j-1) = taud_x(i,j-1) + .5 * taud_scale * dyh * neumann_val + taud_x(i,j) = taud_x(i,j) + .5 * taud_scale * 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 + taud_y(i-1,j-1) = taud_y(i-1,j-1) - .5 * taud_scale * dxh * neumann_val + taud_y(i,j-1) = taud_y(i,j-1) - .5 * taud_scale * 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 + taud_y(i-1,j) = taud_y(i-1,j) + .5 * taud_scale * dxh * neumann_val + taud_y(i,j) = taud_y(i,j) + .5 * taud_scale * dxh * neumann_val endif endif @@ -2280,7 +2313,8 @@ subroutine init_boundary_values(CS, G, time, hmask, input_flux, input_thick, new 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 [Z m2 s-1 ~> m3 s-1] + real, intent(in) :: input_flux !< The integrated inward ice thickness flux per + !! unit face length [Z L s-1 ~> m2 s-1] real, intent(in) :: input_thick !< The ice thickness at boundaries [Z ~> m]. logical, optional, intent(in) :: new_sim !< If present and false, this run is being restarted @@ -2325,6 +2359,7 @@ subroutine init_boundary_values(CS, G, time, hmask, input_flux, input_thick, new endif endif + !### What about v_shelf? 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 @@ -2343,24 +2378,24 @@ subroutine init_boundary_values(CS, G, time, hmask, input_flux, input_thick, new 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) +subroutine CG_action(uret, vret, u_shlf, v_shlf, Phi, Phisub, umask, vmask, hmask, H_node, & + nu, float_cond, bathyT, beta, dxdyh, G, US, 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. + intent(inout) :: uret !< The retarding stresses working at u-points. [L ? ~> m ?] real, dimension(G%IsdB:G%IedB,G%JsdB:G%JedB), & - intent(inout) :: vret !< The retarding stresses working at v-points. + intent(inout) :: vret !< The retarding stresses working at v-points. [L ? ~> m ?] 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. + !! quadrature points surrounding the cell verticies [L-1 ~> m-1]. real, dimension(:,:,:,:,:,:), & intent(in) :: Phisub !< Quadrature structure weights at subgridscale - !! locations for finite element calculations + !! locations for finite element calculations [nondim] real, dimension(SZDIB_(G),SZDJB_(G)), & - intent(in) :: u !< The zonal ice shelf velocity at vertices [m year-1] + intent(in) :: u_shlf !< The zonal ice shelf velocity at vertices [L yr-1 ~> m yr-1] real, dimension(SZDIB_(G),SZDJB_(G)), & - intent(in) :: v !< The meridional ice shelf velocity at vertices [m year-1] + intent(in) :: v_shlf !< The meridional ice shelf velocity at vertices [L yr-1 ~> m yr-1] real, dimension(SZDIB_(G),SZDJB_(G)), & intent(in) :: umask !< A coded mask indicating the nature of the !! zonal flow at the corner point @@ -2376,7 +2411,7 @@ subroutine CG_action(uret, vret, u, v, Phi, Phisub, umask, vmask, hmask, H_node, 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. + !! 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. @@ -2385,12 +2420,13 @@ subroutine CG_action(uret, vret, u, v, Phi, Phisub, umask, vmask, hmask, H_node, 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. + !! units depend on the basal law exponent. [L-2 ? ~> m-2 ?] ! and/or whether flow is "hybridized" real, dimension(SZDI_(G),SZDJ_(G)), & - intent(in) :: dxdyh !< The tracer cell area [m2] + intent(in) :: dxdyh !< The tracer cell area [L2 ~> m2] real, intent(in) :: dens_ratio !< The density of ice divided by the density !! of seawater, nondimensional + type(unit_scale_type), intent(in) :: US !< A structure containing unit conversion factors 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 @@ -2415,10 +2451,11 @@ subroutine CG_action(uret, vret, u, v, Phi, Phisub, umask, vmask, hmask, H_node, ! 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 + real :: ux, vx, uy, vy, uq, vq, basel + real :: area integer :: iq, jq, iphi, jphi, i, j, ilq, jlq real, dimension(2) :: xquad - real, dimension(2,2) :: Ucell,Vcell,Hcell,Usubcontr,Vsubcontr,Ucontr + real, dimension(2,2) :: Ucell,Vcell,Hcell,Usubcontr,Vsubcontr ! ,Ucontr xquad(1) = .5 * (1-sqrt(1./3)) ; xquad(2) = .5 * (1+sqrt(1./3)) @@ -2427,124 +2464,94 @@ subroutine CG_action(uret, vret, u, v, Phi, Phisub, umask, vmask, hmask, H_node, ! 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) +! X(:,:) = G%geoLonBu(i-1:i,j-1:j)*US%m_to_L +! Y(:,:) = G%geoLatBu(i-1:i,j-1:j)*US%m_to_L ! -! call bilinear_shape_functions (X, Y, Phi, area) +! 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 + ! 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 + ! Ucontr=0 do iq=1,2 ; do jq=1,2 + uq = u_shlf(i-1,j-1) * xquad(3-iq) * xquad(3-jq) + & + u_shlf(i,j-1) * xquad(iq) * xquad(3-jq) + & + u_shlf(i-1,j) * xquad(3-iq) * xquad(jq) + & + u_shlf(i,j) * xquad(iq) * xquad(jq) - if (iq == 2) then - ilq = 2 - else - ilq = 1 - endif + vq = v_shlf(i-1,j-1) * xquad(3-iq) * xquad(3-jq) + & + v_shlf(i,j-1) * xquad(iq) * xquad(3-jq) + & + v_shlf(i-1,j) * xquad(3-iq) * xquad(jq) + & + v_shlf(i,j) * xquad(iq) * xquad(jq) - if (jq == 2) then - jlq = 2 - else - jlq = 1 - endif + ux = u_shlf(i-1,j-1) * Phi(i,j,1,2*(jq-1)+iq) + & + u_shlf(i,j-1) * Phi(i,j,3,2*(jq-1)+iq) + & + u_shlf(i-1,j) * Phi(i,j,5,2*(jq-1)+iq) + & + u_shlf(i,j) * Phi(i,j,7,2*(jq-1)+iq) - 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) + vx = v_shlf(i-1,j-1) * Phi(i,j,1,2*(jq-1)+iq) + & + v_shlf(i,j-1) * Phi(i,j,3,2*(jq-1)+iq) + & + v_shlf(i-1,j) * Phi(i,j,5,2*(jq-1)+iq) + & + v_shlf(i,j) * Phi(i,j,7,2*(jq-1)+iq) - 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) + uy = u_shlf(i-1,j-1) * Phi(i,j,2,2*(jq-1)+iq) + & + u_shlf(i,j-1) * Phi(i,j,4,2*(jq-1)+iq) + & + u_shlf(i-1,j) * Phi(i,j,6,2*(jq-1)+iq) + & + u_shlf(i,j) * Phi(i,j,8,2*(jq-1)+iq) - 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) + vy = v_shlf(i-1,j-1) * Phi(i,j,2,2*(jq-1)+iq) + & + v_shlf(i,j-1) * Phi(i,j,4,2*(jq-1)+iq) + & + v_shlf(i-1,j) * Phi(i,j,6,2*(jq-1)+iq) + & + v_shlf(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) + & + 0.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) + & + 0.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 + ilq = 1 ; if (iq == iphi) ilq = 2 + jlq = 1 ; if (jq == jphi) jlq = 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 * beta(i,j) * area * uq * xquad(ilq) * xquad(jlq) - + 0.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) - + 0.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) + Ucell(:,:) = u_shlf(i-1:i,j-1:j) ; Vcell(:,:) = v_shlf(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) + 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) + vret(i-2+iphi,j-2+jphi) = vret(i-2+iphi,j-2+jphi) + Vsubcontr(iphi,jphi) * beta(i,j) endif enddo ; enddo endif @@ -2557,21 +2564,23 @@ 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 + !! locations for finite element calculations [nondim] real, dimension(2,2), intent(in) :: H !< The ice shelf thickness at nodal (corner) points [Z ~> m]. - real, dimension(2,2), intent(in) :: U !< The zonal ice shelf velocity at vertices [m year-1] - real, dimension(2,2), intent(in) :: V !< The meridional ice shelf velocity at vertices [m year-1] - real, intent(in) :: DXDYH !< The tracer cell area [m2] + real, dimension(2,2), intent(in) :: U !< The zonal ice shelf velocity at vertices [L yr-1 ~> m yr-1] + real, dimension(2,2), intent(in) :: V !< The meridional ice shelf velocity at vertices [L yr-1 ~> m yr-1] + real, intent(in) :: DXDYH !< The tracer cell area [L2 ~> m2] real, intent(in) :: bathyT !< The depth of ocean bathymetry at tracer points [Z ~> m]. real, intent(in) :: dens_ratio !< The density of ice divided by the density - !! of seawater, nondimensional + !! of seawater [nondim] real, dimension(2,2), intent(inout) :: Ucontr !< A field related to the subgridscale contributions to - !! the u-direction basal stress. + !! the u-direction basal stress [L3 yr-1 ~> m3 yr-1]. real, dimension(2,2), intent(inout) :: Vcontr !< A field related to the subgridscale contributions to - !! the v-direction basal stress. + !! the v-direction basal stress [L3 yr-1 ~> m3 yr-1]. - integer :: nsub, i, j, k, l, qx, qy, m, n - real :: subarea, hloc, uq, vq + real :: subarea ! A sub-cell area [L2 ~> m2] + real :: hloc ! The local sub-cell ice thickness [Z ~> m] + real :: uq, vq ! Local velocities [L yr-1 ~> m yr-1] + integer :: nsub, i, j, k, l, qx, qy, m, n nsub = size(Phisub,1) subarea = DXDYH / (nsub**2) @@ -2591,8 +2600,8 @@ subroutine CG_action_subgrid_basal(Phisub, H, U, V, DXDYH, bathyT, dens_ratio, U 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) + ! 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 @@ -2612,11 +2621,12 @@ subroutine CG_action_subgrid_basal(Phisub, H, U, V, DXDYH, bathyT, dens_ratio, U 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, & +subroutine matrix_diagonal(CS, G, US, 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. + type(unit_scale_type), intent(in) :: US !< A structure containing unit conversion factors 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. @@ -2630,28 +2640,29 @@ subroutine matrix_diagonal(CS, G, float_cond, H_node, nu, beta, hmask, dens_rati 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 + !! units depend on the basal law exponent [L-2 ? ~> m-2 ?] 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 + !! of seawater [nondim] real, dimension(:,:,:,:,:,:), intent(in) :: Phisub !< Quadrature structure weights at subgridscale - !! locations for finite element calculations + !! locations for finite element calculations [nondim] 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. + !! matrix from the left-hand side of the solver [same units as nu]. 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. + !! matrix from the left-hand side of the solver [same units as nu]. ! 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 :: A, n, ux, uy, vx, vy, eps_min, domain_width + real :: area, uq, vq, basel + real, dimension(8,4) :: Phi ! [L-1 ~> m-1] + real, dimension(4) :: X, Y ! Sub-cell positions [L ~> m] real, dimension(2) :: xquad real, dimension(2,2) :: Hcell,Usubcontr,Vsubcontr @@ -2664,19 +2675,15 @@ subroutine matrix_diagonal(CS, G, float_cond, H_node, nu, beta, hmask, dens_rati ! 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 +! 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%US%L_to_m*G%dxT(i,j) - dyh = G%US%L_to_m*G%dyT(i,j) - dxdyh = G%US%L_to_m**2*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 + X(1:2) = G%geoLonBu(i-1:i,j-1)*1000.0*US%m_to_L + X(3:4) = G%geoLonBu(i-1:i,j) *1000.0*US%m_to_L + Y(1:2) = G%geoLatBu(i-1:i,j-1) *1000.0*US%m_to_L + Y(3:4) = G%geoLatBu(i-1:i,j)*1000.0*US%m_to_L call bilinear_shape_functions(X, Y, Phi, area) @@ -2684,8 +2691,8 @@ subroutine matrix_diagonal(CS, G, float_cond, H_node, nu, beta, hmask, dens_rati ! 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 + ! 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 @@ -2705,40 +2712,40 @@ subroutine matrix_diagonal(CS, G, float_cond, H_node, nu, beta, hmask, dens_rati 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) + 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) + & + 0.25 * G%areaT(i,j) * 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) + 0.25 * beta(i,j) * G%areaT(i,j) * 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) + 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) + & + 0.25 * G%areaT(i,j) * 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) + 0.25 * beta(i,j) * G%areaT(i,j) * vq * xquad(ilq) * xquad(jlq) endif endif @@ -2747,7 +2754,7 @@ subroutine matrix_diagonal(CS, G, float_cond, H_node, nu, beta, hmask, dens_rati 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) + call CG_diagonal_subgrid_basal(Phisub, Hcell, G%areaT(i,j), 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) @@ -2762,22 +2769,23 @@ 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 + !! locations for finite element calculations [nondim] real, dimension(2,2), intent(in) :: H_node !< The ice shelf thickness at nodal (corner) !! points [Z ~> m]. - real, intent(in) :: DXDYH !< The tracer cell area [m2] + real, intent(in) :: DXDYH !< The tracer cell area [L2 ~> m2] real, intent(in) :: bathyT !< The depth of ocean bathymetry at tracer points [Z ~> m]. real, intent(in) :: dens_ratio !< The density of ice divided by the density - !! of seawater, nondimensional + !! of seawater [nondim] real, dimension(2,2), intent(inout) :: Ucontr !< A field related to the subgridscale contributions to - !! the u-direction diagonal elements from basal stress. + !! the u-direction diagonal elements from basal stress [L2 ~> m2]. real, dimension(2,2), intent(inout) :: Vcontr !< A field related to the subgridscale contributions to - !! the v-direction diagonal elements from basal stress. + !! the v-direction diagonal elements from basal stress [L2 ~> m2]. ! bathyT = cellwise-constant bed elevation - integer :: nsub, i, j, k, l, qx, qy, m, n - real :: subarea, hloc + real :: subarea ! The local sub-region area [L2 ~> m2] + real :: hloc ! The local sub-region thickness [Z ~> m] + integer :: nsub, i, j, k, l, qx, qy, m, n nsub = size(Phisub,1) subarea = DXDYH / (nsub**2) @@ -2797,17 +2805,18 @@ subroutine CG_diagonal_subgrid_basal (Phisub, H_node, DXDYH, bathyT, dens_ratio, end subroutine CG_diagonal_subgrid_basal -subroutine apply_boundary_values(CS, ISS, G, time, Phisub, H_node, nu, beta, float_cond, & +subroutine apply_boundary_values(CS, ISS, G, US, 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(unit_scale_type), intent(in) :: US !< A structure containing unit conversion factors 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 + !! locations for finite element calculations [nondim] real, dimension(SZDIB_(G),SZDJB_(G)), & intent(in) :: H_node !< The ice shelf thickness at nodal !! (corner) points [Z ~> m]. @@ -2818,7 +2827,7 @@ subroutine apply_boundary_values(CS, ISS, G, time, Phisub, H_node, nu, beta, flo 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 + !! units depend on the basal law exponent [L-2 ~> m-2] 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. @@ -2826,10 +2835,10 @@ subroutine apply_boundary_values(CS, ISS, G, time, Phisub, H_node, nu, beta, flo !! 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 + !! velocities due to the open boundaries [L yr-1 ~> m yr-1] real, dimension(SZDIB_(G),SZDJB_(G)), & intent(inout) :: v_bdry_contr !< Contributions to the zonal ice - !! velocities due to the open boundaries + !! velocities due to the open boundaries [L yr-1 ~> m yr-1] ! this will be a per-setup function. the boundary values of thickness and velocity ! (and possibly other variables) will be updated in this function @@ -2838,7 +2847,7 @@ subroutine apply_boundary_values(CS, ISS, G, time, Phisub, H_node, nu, beta, flo 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 :: A, n, ux, uy, vx, vy, eps_min, domain_width, uq, vq, area, basel real, dimension(2,2) :: Ucell,Vcell,Hcell,Usubcontr,Vsubcontr @@ -2850,8 +2859,8 @@ subroutine apply_boundary_values(CS, ISS, G, time, Phisub, H_node, nu, beta, flo ! 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 +! 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 @@ -2861,14 +2870,10 @@ subroutine apply_boundary_values(CS, ISS, G, time, Phisub, H_node, nu, beta, flo 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%US%L_to_m*G%dxT(i,j) - dyh = G%US%L_to_m*G%dyT(i,j) - dxdyh = G%US%L_to_m**2*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 + X(1:2) = G%geoLonBu(i-1:i,j-1)*1000.0*US%m_to_L + X(3:4) = G%geoLonBu(i-1:i,j)*1000.0*US%m_to_L + Y(1:2) = G%geoLatBu(i-1:i,j-1)*1000.0*US%m_to_L + Y(3:4) = G%geoLatBu(i-1:i,j)*1000.0*US%m_to_L call bilinear_shape_functions(X, Y, Phi, area) @@ -2876,38 +2881,38 @@ subroutine apply_boundary_values(CS, ISS, G, time, Phisub, H_node, nu, beta, flo ! 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 + ! 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,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,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,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,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,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,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) @@ -2926,15 +2931,13 @@ subroutine apply_boundary_values(CS, ISS, G, time, Phisub, H_node, nu, beta, flo 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) + & + 0.25 * G%areaT(i,j) * 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) + 0.25 * beta(i,j) * G%areaT(i,j) * uq * xquad(ilq) * xquad(jlq) endif endif @@ -2943,12 +2946,12 @@ subroutine apply_boundary_values(CS, ISS, G, time, Phisub, H_node, nu, beta, flo 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) + & + 0.25 * G%areaT(i,j) * 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) + 0.25 * beta(i,j) * G%areaT(i,j) * vq * xquad(ilq) * xquad(jlq) endif endif @@ -2956,19 +2959,19 @@ subroutine apply_boundary_values(CS, ISS, G, time, Phisub, H_node, nu, beta, flo enddo ; enddo if (float_cond(i,j) == 1) then - Usubcontr = 0.0 ; Vsubcontr = 0.0 ; basel = G%bathyT(i,j) + Usubcontr = 0.0 ; Vsubcontr = 0.0 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, & + call CG_action_subgrid_basal(Phisub, Hcell, Ucell, Vcell, G%areaT(i,j), G%bathyT(i,j), & 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) + 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) + Vsubcontr(iphi,jphi) * beta(i,j) endif enddo ; enddo endif @@ -2979,16 +2982,16 @@ 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, US, u, v) +subroutine calc_shelf_visc(CS, ISS, G, US, u_shlf, v_shlf) 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. - type(unit_scale_type), intent(in) :: US !< Pointer to a structure containing unit conversion factors + type(unit_scale_type), intent(in) :: US !< A structure containing unit conversion factors real, dimension(G%IsdB:G%IedB,G%JsdB:G%JedB), & - intent(inout) :: u !< The zonal ice shelf velocity [m year-1]. + intent(inout) :: u_shlf !< The zonal ice shelf velocity [L yr-1 ~> m yr-1]. real, dimension(G%IsdB:G%IedB,G%JsdB:G%JedB), & - intent(inout) :: v !< The meridional ice shelf velocity [m year-1]. + intent(inout) :: v_shlf !< The meridional ice shelf velocity [L yr-1 ~> m yr-1]. ! update DEPTH_INTEGRATED viscosity, based on horizontal strain rates - this is for bilinear FEM solve ! so there is an "upper" and "lower" bilinear viscosity @@ -2999,7 +3002,10 @@ subroutine calc_shelf_visc(CS, ISS, G, US, u, v) 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 + real :: A, n + real :: ux, uy, vx, vy, eps_min ! Velocity shears [yr-1] + real :: umid, vmid, unorm ! Velocities [L yr-1 ~> m yr-1] + real :: n_basal_friction isc = G%isc ; jsc = G%jsc ; iec = G%iec ; jec = G%jec iscq = G%iscB ; iecq = G%iecB ; jscq = G%jscB ; jecq = G%jecB @@ -3010,29 +3016,25 @@ subroutine calc_shelf_visc(CS, ISS, G, US, u, v) 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 + n_basal_friction = CS%n_basal_friction do j=jsd+1,jed-1 do i=isd+1,ied-1 - dxh = US%L_to_m*G%dxT(i,j) - dyh = US%L_to_m*G%dyT(i,j) - dxdyh = US%L_to_m**2*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) + ux = (u_shlf(i,j) + u_shlf(i,j-1) - u_shlf(i-1,j) - u_shlf(i-1,j-1)) / (2*G%dxT(i,j)) + vx = (v_shlf(i,j) + v_shlf(i,j-1) - v_shlf(i-1,j) - v_shlf(i-1,j-1)) / (2*G%dxT(i,j)) + uy = (u_shlf(i,j) - u_shlf(i,j-1) + u_shlf(i-1,j) - u_shlf(i-1,j-1)) / (2*G%dyT(i,j)) + vy = (v_shlf(i,j) - v_shlf(i,j-1) + v_shlf(i-1,j) - v_shlf(i-1,j-1)) / (2*G%dyT(i,j)) 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)) * & + (ux**2 + vy**2 + ux*vy + 0.25*(uy+vx)**2 + eps_min**2) ** ((1-n)/(2*n)) * & US%Z_to_m*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) + umid = (u_shlf(i,j) + u_shlf(i,j-1) + u_shlf(i-1,j) + u_shlf(i-1,j-1))/4 + vmid = (v_shlf(i,j) + v_shlf(i,j-1) + v_shlf(i-1,j) + v_shlf(i-1,j-1))/4 + unorm = sqrt (umid**2 + vmid**2 + (eps_min*G%dxT(i,j))**2) + CS%taub_beta_eff(i,j) = US%L_to_m**2*CS%C_basal_friction * (US%L_to_m*unorm)**(n_basal_friction-1) endif enddo enddo @@ -3042,17 +3044,17 @@ end subroutine calc_shelf_visc subroutine update_OD_ffrac(CS, G, US, 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. - type(unit_scale_type), intent(in) :: US !< Pointer to a structure containing unit conversion factors + type(unit_scale_type), intent(in) :: US !< A structure containing unit conversion factors real, dimension(SZDI_(G),SZDJ_(G)), & intent(in) :: ocean_mass !< The mass per unit area of the ocean [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_rho_ocean ! A typical specific volume of the ocean [R-1 ~> m3 kg-1] real :: I_counter - I_rho_ocean = 1.0 / (US%Z_to_m*CS%density_ocean_avg) + I_rho_ocean = 1.0 / CS%density_ocean_avg isc = G%isc ; jsc = G%jsc ; iec = G%iec ; jec = G%jec @@ -3111,11 +3113,11 @@ end subroutine update_OD_ffrac_uncoupled !! 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(4), intent(in) :: X !< The x-positions of the vertices of the quadrilateral [L ~> m]. + real, dimension(4), intent(in) :: Y !< The y-positions of the vertices of the quadrilateral [L ~> m]. 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 [m2]. + !! quadrature points surrounding the cell verticies [L-1 ~> m-1]. + real, intent(out) :: area !< The quadrilateral cell area [L2 ~> m2]. ! X and Y must be passed in the form ! 3 - 4 @@ -3127,16 +3129,17 @@ subroutine bilinear_shape_functions (X, Y, Phi, area) ! 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(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 + real, dimension(4) :: xquad, yquad ! [nondim] + real :: a,b,c,d ! Various lengths [L ~> m] + real :: xexp, yexp ! [nondim] integer :: node, qpoint, xnode, xq, ynode, yq - 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)) @@ -3148,6 +3151,11 @@ subroutine bilinear_shape_functions (X, Y, Phi, area) 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*) + ! a = (X(2)-X(1)) * (1-yquad(qpoint)) + (X(4)-X(3)) * yquad(qpoint) ! d(x)/d(x*) + ! b = (Y(2)-Y(1)) * (1-yquad(qpoint)) + (Y(4)-Y(3)) * yquad(qpoint) ! d(y)/d(x*) + ! c = (X(3)-X(1)) * (1-xquad(qpoint)) + (X(4)-X(2)) * xquad(qpoint) ! d(x)/d(y*) + ! d = (Y(3)-Y(1)) * (1-xquad(qpoint)) + (Y(4)-Y(2)) * xquad(qpoint) ! d(y)/d(y*) + do node=1,4 xnode = 2-mod(node,2) ; ynode = ceiling(REAL(node)/2) @@ -3164,8 +3172,8 @@ subroutine bilinear_shape_functions (X, Y, Phi, area) 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) + 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 @@ -3178,8 +3186,8 @@ 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 + !! locations for finite element calculations [nondim] + integer, intent(in) :: nsub !< The number of subgridscale quadrature locations in each direction ! this subroutine is a helper for interpolation of floatation condition ! for the purposes of evaluating the terms \int (u,v) \phi_i dx dy in a cell that is @@ -3346,12 +3354,12 @@ subroutine update_velocity_masks(CS, G, hmask, umask, vmask, u_face_mask, v_face !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. + ! 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. + ! umask(i-1:i,j) = 0. + ! vmask(i-1:i,j) = 0. !endif if (i < G%ied) then @@ -3469,7 +3477,7 @@ subroutine ice_shelf_temp(CS, ISS, G, US, time_step, melt_rate, Time) 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(unit_scale_type), intent(in) :: US !< Pointer to a structure containing unit conversion factors + type(unit_scale_type), intent(in) :: US !< A structure containing unit conversion factors real, intent(in) :: time_step !< The time step for this update [s]. real, dimension(SZDI_(G),SZDJ_(G)), & intent(in) :: melt_rate !< basal melt rate [R Z T-1 ~> kg m-2 s-1] @@ -3505,13 +3513,13 @@ subroutine ice_shelf_temp(CS, ISS, G, US, time_step, melt_rate, Time) ! real, dimension(SZDI_(G),SZDJ_(G)) :: th_after_uflux, th_after_vflux, TH - real, dimension(SZDI_(G),SZDJ_(G),4) :: flux_enter + real, dimension(SZDI_(G),SZDJ_(G),4) :: flux_enter ! The ice volume flux into the cell + ! through the 4 cell boundaries [Z L2 ~> m3]. integer :: isd, ied, jsd, jed, i, j, isc, iec, jsc, jec - real :: rho, t_bd, Tsurf + real :: t_bd, Tsurf real :: spy ! The amount of time in a year [T ~> s] real :: adot ! A surface heat exchange coefficient [Z T-1 ~> m s-1]. - rho = CS%density_ice spy = 365. * 86400. * US%s_to_T ! For now adot and Tsurf are defined here adot=surf acc 0.1m/yr, Tsurf=-20oC, vary them later @@ -3619,7 +3627,7 @@ subroutine ice_shelf_advect_temp_x(CS, G, time_step, hmask, h0, h_after_uflux, f !! the zonal mass fluxes [Z ~> m]. real, dimension(SZDI_(G),SZDJ_(G),4), & intent(inout) :: flux_enter !< The integrated temperature flux into - !! the cell through the 4 cell boundaries [degC Z m2 ~> degC m3] + !! the cell through the 4 cell boundaries [degC Z L2 ~> degC m3] ! use will be made of ISS%hmask here - its value at the boundary will be zero, just like uncovered cells @@ -3643,8 +3651,8 @@ subroutine ice_shelf_advect_temp_x(CS, G, time_step, hmask, h0, h_after_uflux, f 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 + real :: u_face ! Zonal velocity at a face, positive if out {L s-1 ~> m s-1] + real :: flux_diff_cell, phi character (len=1) :: debug_str @@ -3677,8 +3685,6 @@ subroutine ice_shelf_advect_temp_x(CS, G, time_step, hmask, h0, h_after_uflux, f if (hmask(i,j) == 1) then - dxh = G%US%L_to_m*G%dxT(i,j) ; dyh = G%US%L_to_m*G%dyT(i,j) ; dxdyh = G%US%L_to_m**2*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 @@ -3689,8 +3695,8 @@ subroutine ice_shelf_advect_temp_x(CS, G, time_step, hmask, h0, h_after_uflux, f 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 + flux_diff_cell = flux_diff_cell + G%dyT(i,j) * time_step * CS%u_flux_bdry_val(i-1,j) * & + CS%t_bdry_val(i-1,j) / G%areaT(i,j) else ! get u-velocity at center of left face @@ -3702,32 +3708,32 @@ subroutine ice_shelf_advect_temp_x(CS, G, time_step, hmask, h0, h_after_uflux, f 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 + flux_diff_cell = flux_diff_cell + ABS(u_face) * G%dyT(i,j) * time_step * stencil(-1) / G%areaT(i,j) 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 * & + flux_diff_cell = flux_diff_cell + ABS(u_face) * G%dyT(i,j)* time_step / G%areaT(i,j) * & (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) + flux_diff_cell = flux_diff_cell + ABS(u_face) * G%dyT(i,j) * time_step / G%areaT(i,j) * 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 * & + flux_diff_cell = flux_diff_cell - ABS(u_face) * G%dyT(i,j) * time_step / G%areaT(i,j) * & (stencil(0) - phi * (stencil(0)-stencil(-1))/2) else - flux_diff_cell = flux_diff_cell - ABS(u_face) * dyh * time_step / dxdyh * stencil(0) + flux_diff_cell = flux_diff_cell - ABS(u_face) * G%dyT(i,j) * time_step / G%areaT(i,j) * 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) + flux_enter(i-1,j,2) = ABS(u_face) * G%dyT(i,j) * time_step * stencil(0) endif endif endif @@ -3739,8 +3745,8 @@ subroutine ice_shelf_advect_temp_x(CS, G, time_step, hmask, h0, h_after_uflux, f 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 + flux_diff_cell = flux_diff_cell + G%dyT(i,j) * time_step * CS%u_flux_bdry_val(i+1,j) *& + CS%t_bdry_val(i+1,j) / G%areaT(i,j) else u_face = 0.5 * (CS%u_shelf(i,j-1) + CS%u_shelf(i,j)) @@ -3750,19 +3756,19 @@ subroutine ice_shelf_advect_temp_x(CS, G, time_step, hmask, h0, h_after_uflux, f 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 + flux_diff_cell = flux_diff_cell + ABS(u_face) * G%dyT(i,j) * time_step * stencil(1) / G%areaT(i,j) 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 * & + flux_diff_cell = flux_diff_cell + ABS(u_face) * G%dyT(i,j) * time_step / G%areaT(i,j) * & (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) + flux_diff_cell = flux_diff_cell + ABS(u_face) * G%dyT(i,j) * time_step / G%areaT(i,j) * stencil(1) endif @@ -3771,18 +3777,18 @@ subroutine ice_shelf_advect_temp_x(CS, G, time_step, hmask, h0, h_after_uflux, f 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 * & + flux_diff_cell = flux_diff_cell - ABS(u_face) * G%dyT(i,j) * time_step / G%areaT(i,j) * & (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) + flux_diff_cell = flux_diff_cell - ABS(u_face) * G%dyT(i,j) * time_step / G%areaT(i,j) * 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) + flux_enter(i+1,j,1) = ABS(u_face) * G%dyT(i,j) * time_step * stencil(0) endif endif @@ -3797,18 +3803,18 @@ subroutine ice_shelf_advect_temp_x(CS, G, time_step, hmask, h0, h_after_uflux, f 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%US%L_to_m*G%dyT(i,j) * time_step * CS%t_bdry_val(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%US%L_to_m*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%dyT(i,j) * time_step * CS%u_flux_bdry_val(i-1,j)*CS%t_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%US%L_to_m*G%dyT(i,j) * time_step * CS%t_bdry_val(i+1,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%US%L_to_m*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,2) = G%dyT(i,j) * time_step * CS%u_flux_bdry_val(i+1,j) * CS%t_bdry_val(i+1,j) endif ! if ((i == is) .AND. (hmask(i,j) == 0) .AND. (hmask(i-1,j) == 1)) then @@ -3851,7 +3857,7 @@ subroutine ice_shelf_advect_temp_y(CS, G, time_step, hmask, h_after_uflux, h_aft !! the meridional mass fluxes [Z ~> m]. real, dimension(SZDI_(G),SZDJ_(G),4), & intent(inout) :: flux_enter !< The integrated temperature flux into - !! the cell through the 4 cell boundaries [degC Z m2 ~> degC m3] + !! the cell through the 4 cell boundaries [degC Z L2 ~> degC m3] ! use will be made of ISS%hmask here - its value at the boundary will be zero, just like uncovered cells @@ -3875,8 +3881,8 @@ subroutine ice_shelf_advect_temp_y(CS, G, time_step, hmask, h_after_uflux, h_aft 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 + real :: v_face ! Pseudo-meridional velocity at a cell face, positive if out {L s-1 ~> m s-1] + real :: flux_diff_cell, phi character(len=1) :: debug_str is = G%isc ; ie = G%iec ; js = G%jsc-1 ; je = G%jec+1 ; isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed @@ -3905,7 +3911,6 @@ subroutine ice_shelf_advect_temp_y(CS, G, time_step, hmask, h_after_uflux, h_aft endif if (hmask(i,j) == 1) then - dxh = G%US%L_to_m*G%dxT(i,j) ; dyh = G%US%L_to_m*G%dyT(i,j) ; dxdyh = G%US%L_to_m**2*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 @@ -3915,8 +3920,8 @@ subroutine ice_shelf_advect_temp_y(CS, G, time_step, hmask, h_after_uflux, h_aft 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 + flux_diff_cell = flux_diff_cell + G%dxT(i,j) * time_step * CS%v_flux_bdry_val(i,j-1) * & + CS%t_bdry_val(i,j-1)/ G%areaT(i,j) else ! get u-velocity at center of left face @@ -3928,31 +3933,32 @@ subroutine ice_shelf_advect_temp_y(CS, G, time_step, hmask, h_after_uflux, h_aft 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 + flux_diff_cell = flux_diff_cell + ABS(v_face) * G%dxT(i,j) * time_step * stencil(-1) / G%areaT(i,j) 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 * & + flux_diff_cell = flux_diff_cell + ABS(v_face) * G%dxT(i,j) * time_step / G%areaT(i,j) * & (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) + flux_diff_cell = flux_diff_cell + ABS(v_face) * G%dxT(i,j) * time_step / G%areaT(i,j) * 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 * & + flux_diff_cell = flux_diff_cell - ABS(v_face) * G%dxT(i,j) * time_step / G%areaT(i,j) * & (stencil(0) - phi * (stencil(0)-stencil(-1))/2) else - flux_diff_cell = flux_diff_cell - ABS(v_face) * dxh * time_step / dxdyh * stencil(0) + flux_diff_cell = flux_diff_cell - ABS(v_face) * G%dxT(i,j) * time_step / G%areaT(i,j) * stencil(0) + !### The G%dyT(i,j) below needs to be G%dxCv(i,J) 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) + flux_enter(i,j-1,4) = ABS(v_face) * G%dyT(i,j) * time_step * stencil(0) endif endif @@ -3965,8 +3971,8 @@ subroutine ice_shelf_advect_temp_y(CS, G, time_step, hmask, h_after_uflux, h_aft 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 + flux_diff_cell = flux_diff_cell + G%dxT(i,j) * time_step * CS%v_flux_bdry_val(i,j+1) *& + CS%t_bdry_val(i,j+1)/ G%areaT(i,j) else ! get u-velocity at center of right face @@ -3976,29 +3982,29 @@ subroutine ice_shelf_advect_temp_y(CS, G, time_step, hmask, h_after_uflux, h_aft 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 + flux_diff_cell = flux_diff_cell + ABS(v_face) * G%dxT(i,j) * time_step * stencil(1) / G%areaT(i,j) 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 * & + flux_diff_cell = flux_diff_cell + ABS(v_face) * G%dxT(i,j) * time_step / G%areaT(i,j) * & (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) + flux_diff_cell = flux_diff_cell + ABS(v_face) * G%dxT(i,j) * time_step / G%areaT(i,j) * 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 * & + flux_diff_cell = flux_diff_cell - ABS(v_face) * G%dxT(i,j) * time_step / G%areaT(i,j) * & (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) + flux_diff_cell = flux_diff_cell - ABS(v_face) * G%dxT(i,j) * time_step / G%areaT(i,j) * 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) + flux_enter(i,j+1,3) = ABS(v_face) * G%dxT(i,j) * time_step * stencil(0) endif endif @@ -4012,18 +4018,18 @@ subroutine ice_shelf_advect_temp_y(CS, G, time_step, hmask, h_after_uflux, h_aft 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%US%L_to_m*G%dxT(i,j) * time_step * CS%t_bdry_val(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%US%L_to_m*G%dxT(i,j) * time_step * CS%v_flux_bdry_val(i,j-1)*CS%t_bdry_val(i,j-1) + 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) 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%US%L_to_m*G%dxT(i,j) * time_step * CS%t_bdry_val(i,j+1)* & + 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%US%L_to_m*G%dxT(i,j) * time_step * CS%v_flux_bdry_val(i,j+1)*CS%t_bdry_val(i,j+1) + 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) endif ! if ((j == js) .AND. (hmask(i,j) == 0) .AND. (hmask(i,j-1) == 1)) then diff --git a/src/ice_shelf/MOM_ice_shelf_initialize.F90 b/src/ice_shelf/MOM_ice_shelf_initialize.F90 index 16eb923fd4..f34b3c70f4 100644 --- a/src/ice_shelf/MOM_ice_shelf_initialize.F90 +++ b/src/ice_shelf/MOM_ice_shelf_initialize.F90 @@ -240,30 +240,31 @@ end subroutine initialize_ice_thickness_channel !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 ) +! hmask, G, US, 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 [m2 s-1]. +! !! C-grid u faces [L Z s-1 ~> 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 [m2 s-1]. +! !! C-grid v faces [L Z s-1 ~> m2 s-1]. ! real, dimension(SZIB_(G),SZJB_(G)), & ! intent(inout) :: u_bdry_val !< The zonal ice shelf velocity at open - !! boundary vertices [m yr-1]. +! !! boundary vertices [m yr-1]. ! real, dimension(SZIB_(G),SZJB_(G)), & ! intent(inout) :: v_bdry_val !< The meridional ice shelf velocity at open - !! boundary vertices [m yr-1]. +! !! boundary vertices [m yr-1]. ! 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(unit_scale_type), intent(in) :: US !< A structure containing unit conversion factors ! type(param_file_type), intent(in) :: PF !< A structure to parse for run-time parameters ! character(len=40) :: mdl = "initialize_ice_shelf_boundary" ! This subroutine's name. @@ -296,19 +297,19 @@ end subroutine initialize_ice_thickness_channel ! 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 ) +! hmask, G, flux_bdry, US, 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 [m2 s-1]. +! !! C-grid u faces [L Z s-1 ~> 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 [m2 s-1]. +! !! C-grid v faces [L Z s-1 ~> m2 s-1]. ! real, dimension(SZIB_(G),SZJB_(G)), & ! intent(inout) :: u_bdry_val !< The zonal ice shelf velocity at open !! boundary vertices [m yr-1]. @@ -321,17 +322,20 @@ end subroutine initialize_ice_thickness_channel ! 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(unit_scale_type), intent(in) :: US !< A structure containing unit conversion factors ! type(param_file_type), intent(in) :: PF !< A structure to parse for run-time parameters ! character(len=40) :: mdl = "initialize_ice_shelf_boundary_channel" ! This subroutine's name. ! integer :: i, j, isd, jsd, is, js, iegq, jegq, giec, gjec, gisc, gjsc, isc, jsc, iec, jec, ied, jed -! real :: lenlat, input_thick, input_flux, len_stress +! real :: input_thick +! real :: input_flux ! The input ice flux per unit length [L Z t-1 ~> m2 s-1] +! real :: lenlat, len_stress ! call get_param(PF, mdl, "LENLAT", lenlat, fail_if_missing=.true.) ! call get_param(PF, mdl, "INPUT_FLUX_ICE_SHELF", input_flux, & ! "volume flux at upstream boundary", & -! units="m2 s-1", default=0.) +! units="m2 s-1", default=0., scale=US%m_to_L*US%m_to_Z) ! call get_param(PF, mdl, "INPUT_THICK_ICE_SHELF", input_thick, & ! "flux thickness at upstream boundary", & ! units="m", default=1000.) From d77c80319818184198b747df143afccd043f8131 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 25 Mar 2020 21:23:29 -0400 Subject: [PATCH 123/316] +Rescaled velocities in MOM_ice_shelf_dynamics.F90 Change the internal units of the ice shelf velocities from [L yr-1] to [m s-1] although diagnostics are still available in [L yr-1]. Also added dimensional rescaling of velocities and timesteps, along with other simplifying code changes in MOM_ice_shelf_dynamics.F90. Some unused code blocks were eliminated altogether and the new subroutine bilinear_shape_fn_grid was added to set up the finite element structure variables from MOM6's grid type, instead of making the assumption that a Cartesian grid is used with axes labeled in km. Also added comments describing many of the variables and their units. All answers are bitwise identical in the MOM6-examples test cases, but there are substantial changes to the MOM_ice_shelf_dynamics.F90 code and it should be noted that there are no active tests of the ice shelf dynamics code. --- src/ice_shelf/MOM_ice_shelf.F90 | 13 +- src/ice_shelf/MOM_ice_shelf_dynamics.F90 | 1181 ++++++++------------ src/ice_shelf/MOM_ice_shelf_initialize.F90 | 28 +- 3 files changed, 504 insertions(+), 718 deletions(-) diff --git a/src/ice_shelf/MOM_ice_shelf.F90 b/src/ice_shelf/MOM_ice_shelf.F90 index 8299d954b2..cd3ba3fd44 100644 --- a/src/ice_shelf/MOM_ice_shelf.F90 +++ b/src/ice_shelf/MOM_ice_shelf.F90 @@ -665,7 +665,7 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) ! 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, US, time_step, Time, & + call update_ice_shelf(CS%dCS, ISS, G, US, US%s_to_T*time_step, Time, & US%kg_m3_to_R*US%m_to_Z*state%ocean_mass(:,:), coupled_GL) endif @@ -1786,9 +1786,9 @@ subroutine ice_shelf_end(CS) end subroutine ice_shelf_end !> This routine is for stepping a stand-alone ice shelf model without an ocean. -subroutine solo_time_step(CS, time_step, nsteps, Time, min_time_step_in) +subroutine solo_time_step(CS, time_interval, 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 [s]. + real, intent(in) :: time_interval !< The time interval for this update [s]. integer, intent(inout) :: nsteps !< The running number of ice shelf steps. type(time_type), intent(inout) :: Time !< The current model time real, optional, intent(in) :: min_time_step_in !< The minimum permitted time step [s]. @@ -1799,6 +1799,7 @@ subroutine solo_time_step(CS, time_step, nsteps, Time, min_time_step_in) 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 real :: time_step_remain real :: time_step_int, min_time_step character(len=240) :: mesg @@ -1811,6 +1812,8 @@ subroutine solo_time_step(CS, time_step, nsteps, Time, min_time_step_in) ISS => CS%ISS is = G%isc ; iec = G%iec ; js = G%jsc ; jec = G%jec + time_step = time_interval + time_step_remain = time_step if (present (min_time_step_in)) then min_time_step = min_time_step_in @@ -1825,7 +1828,7 @@ subroutine solo_time_step(CS, time_step, nsteps, Time, min_time_step_in) nsteps = nsteps+1 ! If time_step is not too long, this is unnecessary. - time_step_int = min(ice_time_step_CFL(CS%dCS, ISS, G), time_step) + time_step_int = min(US%T_to_s*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 @@ -1846,7 +1849,7 @@ subroutine solo_time_step(CS, time_step, nsteps, Time, min_time_step_in) update_ice_vel = ((time_step_int > min_time_step) .or. (time_step_int >= time_step)) coupled_GL = .false. - call update_ice_shelf(CS%dCS, ISS, G, US, time_step_int, Time, must_update_vel=update_ice_vel) + call update_ice_shelf(CS%dCS, ISS, G, US, US%s_to_T*time_step_int, Time, must_update_vel=update_ice_vel) 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) diff --git a/src/ice_shelf/MOM_ice_shelf_dynamics.F90 b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 index 0fc319c621..908e79896a 100644 --- a/src/ice_shelf/MOM_ice_shelf_dynamics.F90 +++ b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 @@ -8,7 +8,7 @@ module MOM_ice_shelf_dynamics 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_diag_mediator, only : diag_ctrl, time_type, enable_averages, 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 @@ -39,10 +39,10 @@ module MOM_ice_shelf_dynamics !> 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 - !! on q-points (B grid) [L yr-1 ~> m yr-1] + real, pointer, dimension(:,:) :: u_shelf => NULL() !< the zonal velocity of the ice shelf/sheet + !! on q-points (B grid) [L T-1 ~> m s-1] real, pointer, dimension(:,:) :: v_shelf => NULL() !< the meridional velocity of the ice shelf/sheet - !! on q-points (B grid) [L yr-1 ~> m yr-1] + !! on q-points (B grid) [L T-1 ~> m s-1] real, pointer, dimension(:,:) :: u_face_mask => NULL() !< mask for velocity boundary conditions on the C-grid !! u-face - this is because the FEM cares about FACES THAT GET INTEGRATED OVER, @@ -57,9 +57,9 @@ module MOM_ice_shelf_dynamics real, pointer, dimension(:,:) :: u_face_mask_bdry => NULL() !< A duplicate copy of u_face_mask? real, pointer, dimension(:,:) :: v_face_mask_bdry => NULL() !< A duplicate copy of v_face_mask? real, pointer, dimension(:,:) :: u_flux_bdry_val => NULL() !< The ice volume flux per unit face length into the cell - !! through open boundary u-faces (where u_face_mask=4) [Z L s-1 ~> m2 s-1] + !! through open boundary u-faces (where u_face_mask=4) [Z L T-1 ~> m2 s-1] real, pointer, dimension(:,:) :: v_flux_bdry_val => NULL() !< The ice volume flux per unit face length into the cell - !! through open boundary v-faces (where v_face_mask=4) [Z L s-1 ~> m2 s-1]?? + !! through open boundary v-faces (where v_face_mask=4) [Z L T-1 ~> m2 s-1]?? ! needed where u_face_mask is equal to 4, similary for v_face_mask real, pointer, dimension(:,:) :: umask => NULL() !< u-mask on the actual degrees of freedom (B grid) !! 1=normal node, 3=inhomogeneous boundary node, @@ -81,7 +81,7 @@ module MOM_ice_shelf_dynamics real, pointer, dimension(:,:) :: h_bdry_val => NULL() !< The ice thickness at inflowing boundaries [m]. real, pointer, dimension(:,:) :: t_bdry_val => NULL() !< The ice temperature at inflowing boundaries [degC]. - real, pointer, dimension(:,:) :: taub_beta_eff => NULL() !< nonlinear part of "linearized" basal stress. + real, pointer, dimension(:,:) :: basal_traction => NULL() !< nonlinear part of "linearized" basal stress. !! [L-2 ? ~> m-2 ?] !! The exact form depends on basal law exponent and/or whether flow is "hybridized" a la Goldberg 2011 @@ -94,12 +94,12 @@ module MOM_ice_shelf_dynamics integer :: OD_rt_counter = 0 !< A counter of the number of contributions to OD_rt. real :: velocity_update_time_step !< The time interval over which to update the ice shelf velocity - !! using the nonlinear elliptic equation, or 0 to update every timestep [s]. + !! using the nonlinear elliptic equation, or 0 to update every timestep [T ~> s]. ! 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 [s]. + real :: elapsed_velocity_time !< The elapsed time since the ice velocies were last updated [T ~> s]. real :: g_Earth !< The gravitational acceleration [L2 Z-1 T-2 ~> m s-2]. real :: density_ice !< A typical density of ice [R ~> kg m-3]. @@ -119,12 +119,12 @@ module MOM_ice_shelf_dynamics 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 !< Ice viscosity parameter in Glen's Law, [Pa-1/3 year]. + real :: A_glen_isothermal !< Ice viscosity parameter in Glen's Law, [Pa-3 s-1]. real :: n_glen !< Nonlinearity exponent in Glen's Law real :: eps_glen_min !< Min. strain rate to avoid infinite Glen's law viscosity, [year-1]. - real :: C_basal_friction !< Ceofficient in sliding law tau_b = C u^(n_basal_friction), in - !! units="Pa (m-a)-(n_basal_friction) - real :: n_basal_friction !< Exponent in sliding law tau_b = C u^(m_slide) + real :: C_basal_friction !< Coefficient in sliding law tau_b = C u^(n_basal_fric), in + !! units= Pa (m yr-1)-(n_basal_fric) + real :: n_basal_fric !< Exponent in sliding law tau_b = C u^(m_slide) real :: density_ocean_avg !< A typical ocean density [R ~> kg m-3]. This does not affect ocean !! circulation or thermodynamics. It is used to estimate the !! gravitational driving force at the shelf front (until we think of @@ -140,8 +140,7 @@ module MOM_ice_shelf_dynamics !! that sets when to stop the iterative velocity solver integer :: cg_max_iterations !< The maximum number of iterations that can be used in the CG solver 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 reproducing global sums. + !! 2: exit based on "fixed point" metric (|u - u_last| / |u| < tol) where | | is infty-norm ! 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 @@ -240,7 +239,7 @@ subroutine register_ice_shelf_dyn_restarts(G, param_file, CS, restart_CS) 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%basal_traction(isd:ied,jsd:jed) ) ; CS%basal_traction(:,:) = 0.0 allocate( CS%OD_av(isd:ied,jsd:jed) ) ; CS%OD_av(:,:) = 0.0 allocate( CS%ground_frac(isd:ied,jsd:jed) ) ; CS%ground_frac(:,:) = 0.0 @@ -257,7 +256,7 @@ subroutine register_ice_shelf_dyn_restarts(G, param_file, CS, 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, & + call register_restart_field(CS%basal_traction, "tau_b_beta", .true., restart_CS, & "Coefficient of basal traction", "m (seems wrong)") endif @@ -282,8 +281,8 @@ subroutine initialize_ice_shelf_dyn(param_file, Time, ISS, CS, G, US, diag, new_ ! Local variables real :: Z_rescale ! A rescaling factor for heights from the representation in ! a restart file to the internal representation in this run. - real :: L_rescale ! A rescaling factor for horizontal lenghts from the representation in - ! a restart file to the internal representation in this run. + real :: vel_rescale ! A rescaling factor for horizontal velocities from the representation + ! in a restart file to the internal representation in this run. !This include declares and sets the variable "version". # include "version_variable.h" character(len=200) :: config @@ -352,7 +351,7 @@ subroutine initialize_ice_shelf_dyn(param_file, Time, ISS, CS, G, US, diag, new_ units="kg m-3", default=1035., scale=US%kg_m3_to_R) 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", & + "seconds between ice velocity calcs", units="s", scale=US%s_to_T, & fail_if_missing=.true.) call get_param(param_file, mdl, "G_EARTH", CS%g_Earth, & "The gravitational acceleration of the Earth.", & @@ -360,19 +359,21 @@ subroutine initialize_ice_shelf_dyn(param_file, Time, ISS, CS, G, US, diag, new_ 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) + units="Pa-3 yr-1", default=9.461e-18, scale=1.0/(365.0*86400.0)) + ! This default is equivalent to 3.0001e-25 Pa-3 s-1, appropriate at about -10 C. 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="a-1", default=1.e-12, scale=US%T_to_s/(365.0*86400.0)) + call get_param(param_file, mdl, "BASAL_FRICTION_EXP", CS%n_basal_fric, & + "Exponent in sliding law \tau_b = C u^(n_basal_fric)", & units="none", fail_if_missing=.true.) + call get_param(param_file, mdl, "BASAL_FRICTION_COEFF", CS%C_basal_friction, & + "Coefficient in sliding law \tau_b = C u^(n_basal_fric)", & + units="Pa (m yr-1)-(n_basal_fric)", scale=US%kg_m2s_to_RZ_T*((365.0*86400.0)**CS%n_basal_fric), & + 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, scale=US%kg_m3_to_R) call get_param(param_file, mdl, "CONJUGATE_GRADIENT_TOLERANCE", CS%cg_tolerance, & @@ -388,9 +389,6 @@ subroutine initialize_ice_shelf_dyn(param_file, Time, ISS, CS, G, US, diag, new_ 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) 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 "//& - "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).", & @@ -447,11 +445,12 @@ subroutine initialize_ice_shelf_dyn(param_file, Time, ISS, CS, G, US, diag, new_ enddo ; enddo endif - if ((US%m_to_L_restart /= 0.0) .and. (US%m_to_L_restart /= US%m_to_L)) then - L_rescale = US%m_to_L / US%m_to_L_restart + if ((US%m_to_L_restart*US%s_to_T_restart /= 0.0) .and. & + (US%m_to_L_restart /= US%m_s_to_L_T*US%s_to_T_restart)) then + vel_rescale = US%m_s_to_L_T*US%s_to_T_restart / US%m_to_L_restart do J=G%jsc-1,G%jec ; do I=G%isc-1,G%iec - CS%u_shelf(I,J) = L_rescale * CS%u_shelf(I,J) - CS%v_shelf(I,J) = L_rescale * CS%v_shelf(I,J) + CS%u_shelf(I,J) = vel_rescale * CS%u_shelf(I,J) + CS%v_shelf(I,J) = vel_rescale * CS%v_shelf(I,J) enddo ; enddo endif @@ -477,7 +476,7 @@ subroutine initialize_ice_shelf_dyn(param_file, Time, ISS, CS, G, US, diag, new_ call pass_var(CS%OD_av,G%domain) call pass_var(CS%ground_frac,G%domain) call pass_var(CS%ice_visc,G%domain) - call pass_var(CS%taub_beta_eff,G%domain) + call pass_var(CS%basal_traction, G%domain) call pass_vector(CS%u_shelf, CS%v_shelf, G%domain, TO_ALL, BGRID_NE) endif @@ -520,9 +519,9 @@ subroutine initialize_ice_shelf_dyn(param_file, Time, ISS, CS, G, US, diag, new_ ! Register diagnostics. CS%id_u_shelf = register_diag_field('ocean_model','u_shelf',CS%diag%axesCu1, Time, & - 'x-velocity of ice', 'm yr-1', conversion=US%L_to_m) + 'x-velocity of ice', 'm yr-1', conversion=365.0*86400.0*US%L_T_to_m_s) CS%id_v_shelf = register_diag_field('ocean_model','v_shelf',CS%diag%axesCv1, Time, & - 'y-velocity of ice', 'm yr-1', conversion=US%L_to_m) + 'y-velocity of ice', 'm yr-1', conversion=365.0*86400.0*US%L_T_to_m_s) 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, & @@ -561,7 +560,8 @@ subroutine initialize_diagnostic_fields(CS, ISS, G, US, Time) type(time_type), intent(in) :: Time !< The current model time integer :: i, j, iters, isd, ied, jsd, jed - real :: rhoi_rhow, OD + real :: rhoi_rhow + real :: OD ! Depth of open water below the ice shelf [Z ~> m] type(time_type) :: dummy_time rhoi_rhow = CS%density_ice / CS%density_ocean_avg @@ -586,37 +586,34 @@ subroutine initialize_diagnostic_fields(CS, ISS, G, US, Time) end subroutine initialize_diagnostic_fields -!> This function returns the global maximum timestep that can be taken based on the current +!> This function returns the global maximum advective 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 based on the ice velocities [s]. + real :: ice_time_step_CFL !< The maximum permitted timestep based on the ice velocities [T ~> s]. - real :: ratio, min_ratio ! These should be the minimum stable timesteps at a CFL of 1 [years] - real :: local_u_max, local_v_max ! The largest neighboring velocities [L yr-1 ~> m yr-1] + real :: dt_local, min_dt ! These should be the minimum stable timesteps at a CFL of 1 [T ~> s] + real :: min_vel ! A minimal velocity for estimating a timestep [L T-1 ~> m s-1] integer :: i, j - min_ratio = 1.0e16 ! This is just an arbitrary large nondimensional value. + min_dt = 5.0e17*G%US%s_to_T ! The starting maximum is roughly the lifetime of the universe. + min_vel = (1.0e-12/(365.0*86400.0)) * G%US%m_s_to_L_T do j=G%jsc,G%jec ; do i=G%isc,G%iec ; if (ISS%hmask(i,j) == 1.0) then - 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))) - - ! Here the hard-coded 1e-12 has units of m year-1. Consider revising. - !### Ratio should be a timestep in {s] or [yr], but this expression appears to be in [m yr] - ratio = G%US%L_to_m*min(G%areaT(i,j) / (local_u_max + 1.0e-12*G%US%m_to_L), & - G%areaT(i,j) / (local_v_max + 1.0e-12*G%US%m_to_L)) - min_ratio = min(min_ratio, ratio) + dt_local = 2.0*G%areaT(i,j) / & + ((G%dyCu(I,j) * max(abs(CS%u_shelf(I,J) + CS%u_shelf(I,j-1)), min_vel) + & + G%dyCu(I-1,j)* max(abs(CS%u_shelf(I-1,J)+ CS%u_shelf(I-1,j-1)), min_vel)) + & + (G%dxCv(i,J) * max(abs(CS%v_shelf(i,J) + CS%v_shelf(i-1,J)), min_vel) + & + G%dxCv(i,J-1)* max(abs(CS%v_shelf(i,J-1)+ CS%v_shelf(i-1,J-1)), min_vel))) + + min_dt = min(min_dt, dt_local) endif ; enddo ; enddo ! i- and j- loops - call min_across_PEs(min_ratio) + call min_across_PEs(min_dt) - ! solved velocities are in m/yr; we want time_step_int in seconds - ice_time_step_CFL = CS%CFL_factor * min_ratio * (365*86400) + ice_time_step_CFL = CS%CFL_factor * min_dt end function ice_time_step_CFL @@ -628,7 +625,7 @@ subroutine update_ice_shelf(CS, ISS, G, US, time_step, Time, ocean_mass, coupled !! the ice-shelf state type(ocean_grid_type), intent(inout) :: G !< The grid structure used by the ice shelf. type(unit_scale_type), intent(in) :: US !< A structure containing unit conversion factors - real, intent(in) :: time_step !< time step [s] + real, intent(in) :: time_step !< time step [T ~> s] 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 per unit area @@ -663,7 +660,7 @@ subroutine update_ice_shelf(CS, ISS, G, US, time_step, Time, ocean_mass, coupled call ice_shelf_temp(CS, ISS, G, US, time_step, ISS%water_flux, Time) if (update_ice_vel) then - call enable_averaging(CS%elapsed_velocity_time, Time, CS%diag) + call enable_averages(CS%elapsed_velocity_time, Time, CS%diag) if (CS%id_col_thick > 0) call post_data(CS%id_col_thick, CS%OD_av, CS%diag) if (CS%id_u_shelf > 0) call post_data(CS%id_u_shelf, CS%u_shelf, CS%diag) if (CS%id_v_shelf > 0) call post_data(CS%id_v_shelf, CS%v_shelf, CS%diag) @@ -690,7 +687,7 @@ subroutine ice_shelf_advect(CS, ISS, G, time_step, Time) 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 [s] + real, intent(in) :: time_step !< time step [T ~> s] type(time_type), intent(in) :: Time !< The current model time @@ -729,9 +726,6 @@ subroutine ice_shelf_advect(CS, ISS, G, time_step, Time) real, dimension(SZDI_(G),SZDJ_(G),4) :: flux_enter ! The ice volume flux into the cell ! through the 4 cell boundaries [Z L2 ~> m3]. integer :: isd, ied, jsd, jed, i, j, isc, iec, jsc, jec - real :: spy - - 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 @@ -745,16 +739,16 @@ subroutine ice_shelf_advect(CS, ISS, G, time_step, Time) 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 ice_shelf_advect_thickness_x(CS, G, time_step, 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) +! call enable_averages(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 ice_shelf_advect_thickness_y(CS, G, time_step, ISS%hmask, h_after_uflux, h_after_vflux, flux_enter) -! call enable_averaging(time_step,Time,CS%diag) +! call enable_averages(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) @@ -776,11 +770,11 @@ subroutine ice_shelf_advect(CS, ISS, G, time_step, Time) endif endif - !call enable_averaging(time_step,Time,CS%diag) + !call enable_averages(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 change_thickness_using_melt(ISS, G, US%T_to_s*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) @@ -793,32 +787,32 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u_shlf, v_shlf, iters, time) type(ocean_grid_type), intent(inout) :: G !< The grid structure used by the ice shelf. type(unit_scale_type), intent(in) :: US !< A structure containing unit conversion factors real, dimension(SZDIB_(G),SZDJB_(G)), & - intent(inout) :: u_shlf !< The zonal ice shelf velocity at vertices [L yr-1 ~> m yr-1] + intent(inout) :: u_shlf !< The zonal ice shelf velocity at vertices [L T-1 ~> m s-1] real, dimension(SZDIB_(G),SZDJB_(G)), & - intent(inout) :: v_shlf !< The meridional ice shelf velocity at vertices [L yr-1 ~> m yr-1] + intent(inout) :: v_shlf !< The meridional ice shelf velocity at vertices [L T-1 ~> m s-1] 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 ! Driving stresses at q-points [kg L s-2 ~> kg m s-2] - ! The units should be [R L3 Z T-2 ~> kg m s-2] - real, dimension(SZDIB_(G),SZDJB_(G)) :: u_bdry_cont, v_bdry_cont ! Boundary velocity contributions [L yr-1 ~> m yr-1] - real, dimension(SZDIB_(G),SZDJB_(G)) :: Au, Av ! A term in the momentum balance [L ? ~> m ?] + real, dimension(SZDIB_(G),SZDJB_(G)) :: taudx, taudy ! Driving stresses at q-points [R L3 Z T-2 ~> kg m s-2] + real, dimension(SZDIB_(G),SZDJB_(G)) :: u_bdry_cont ! Boundary u-stress contribution [R L3 Z T-2 ~> kg m s-2] + real, dimension(SZDIB_(G),SZDJB_(G)) :: v_bdry_cont ! Boundary v-stress contribution [R L3 Z T-2 ~> kg m s-2] + real, dimension(SZDIB_(G),SZDJB_(G)) :: Au, Av ! The retarding lateral stress contributions [R L3 Z T-2 ~> kg m s-2] real, dimension(SZDIB_(G),SZDJB_(G)) :: err_u, err_v - real, dimension(SZDIB_(G),SZDJB_(G)) :: u_last, v_last ! Previous velocities [L yr-1 ~> m yr-1] + real, dimension(SZDIB_(G),SZDJB_(G)) :: u_last, v_last ! Previous velocities [L T-1 ~> m s-1] real, dimension(SZDIB_(G),SZDJB_(G)) :: H_node ! Ice shelf thickness at corners [Z ~> m]. real, dimension(SZDI_(G),SZDJ_(G)) :: float_cond ! An array indicating where the ice ! shelf is floating: 0 if floating, 1 if not. character(len=160) :: mesg ! The text of an error message integer :: conv_flag, i, j, k,l, iter - integer :: isdq, iedq, jsdq, jedq, isd, ied, jsd, jed, isumstart, jsumstart, nodefloat, nsub - real :: err_max, err_tempu, err_tempv, err_init, area, max_vel, tempu, tempv, rhoi_rhow + integer :: isdq, iedq, jsdq, jedq, isd, ied, jsd, jed, nodefloat, nsub + real :: err_max, err_tempu, err_tempv, err_init, area, max_vel, tempu, tempv + real :: rhoi_rhow ! The density of ice divided by a typical water density [nondim] real, pointer, dimension(:,:,:,:) :: Phi => NULL() ! The gradients of bilinear basis elements at Gaussian ! quadrature points surrounding the cell verticies [m-1]. real, pointer, dimension(:,:,:,:,:,:) :: Phisub => NULL() ! Quadrature structure weights at subgridscale ! locations for finite element calculations [nondim] real, dimension(8,4) :: Phi_temp ! The gradients of bilinear basis elements at Gaussian ! quadrature points surrounding a cell vertex [L-1 ~> m-1]. - real, dimension(2,2) :: X, Y ! Positions on cell [L ~> m] character(2) :: iternum character(2) :: numproc @@ -829,7 +823,7 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u_shlf, v_shlf, iters, time) isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed rhoi_rhow = CS%density_ice / CS%density_ocean_avg - TAUDX(:,:) = 0.0 ; TAUDY(:,:) = 0.0 + taudx(:,:) = 0.0 ; taudy(:,:) = 0.0 u_bdry_cont(:,:) = 0.0 ; v_bdry_cont(:,:) = 0.0 Au(:,:) = 0.0 ; Av(:,:) = 0.0 @@ -837,15 +831,7 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u_shlf, v_shlf, iters, time) float_cond(:,:) = 0.0 ; H_node(:,:) = 0.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, US, TAUDX, TAUDY, CS%OD_av) + call calc_shelf_driving_stress(CS, ISS, G, US, 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 @@ -859,23 +845,20 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u_shlf, v_shlf, iters, time) 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%ground_frac(i,j) = 1.0 + do j=G%jsc,G%jec ; do i=G%isc,G%iec + nodefloat = 0 + + do l=0,1 ; do k=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 + enddo ; enddo + if ((nodefloat > 0) .and. (nodefloat < 4)) then + float_cond(i,j) = 1.0 + CS%ground_frac(i,j) = 1.0 + endif + enddo ; enddo call pass_var(float_cond, G%Domain) @@ -883,65 +866,49 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u_shlf, v_shlf, iters, time) endif - ! make above conditional - ! 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.0*US%m_to_L - Y(:,:) = G%geoLatBu(i-1:i,j-1:j)*1000.0*US%m_to_L - else - X(2,:) = G%geoLonBu(i,j)*1000.0*US%m_to_L - X(1,:) = G%geoLonBu(i,j)*1000.0*US%m_to_L - G%dxT(i,j) - Y(:,2) = G%geoLatBu(i,j)*1000.0*US%m_to_L - Y(:,1) = G%geoLatBu(i,j)*1000.0*US%m_to_L - G%dyT(i,j) - endif - - call bilinear_shape_functions(X, Y, Phi_temp, area) + call bilinear_shape_fn_grid(G, i, j, Phi_temp) Phi(i,j,:,:) = Phi_temp enddo ; enddo call calc_shelf_visc(CS, ISS, G, US, u_shlf, v_shlf) call pass_var(CS%ice_visc, G%domain) - call pass_var(CS%taub_beta_eff, G%domain) + call pass_var(CS%basal_traction, 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%ground_frac(i,j) + CS%basal_traction(i,j) = CS%basal_traction(i,j) * CS%ground_frac(i,j) enddo ; enddo call apply_boundary_values(CS, ISS, G, US, time, Phisub, H_node, CS%ice_visc, & - CS%taub_beta_eff, float_cond, rhoi_rhow, u_bdry_cont, v_bdry_cont) + CS%basal_traction, float_cond, rhoi_rhow, u_bdry_cont, v_bdry_cont) Au(:,:) = 0.0 ; Av(:,:) = 0.0 call CG_action(Au, Av, u_shlf, v_shlf, Phi, Phisub, CS%umask, CS%vmask, ISS%hmask, H_node, & - CS%ice_visc, float_cond, G%bathyT, CS%taub_beta_eff, G%areaT, & + CS%ice_visc, float_cond, G%bathyT, CS%basal_traction, G%areaT, & G, US, 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)) + if (CS%nonlin_solve_err_mode == 1) then + err_init = 0 ; err_tempu = 0 ; err_tempv = 0 + do J=G%IscB,G%JecB ; do I=G%IscB,G%IecB + if (CS%umask(I,J) == 1) then + err_tempu = ABS(Au(I,J) + u_bdry_cont(I,J) - taudx(I,J)) + if (err_tempu >= err_init) err_init = err_tempu 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 + err_tempv = ABS(Av(I,J) + v_bdry_cont(I,J) - taudy(I,J)) + if (err_tempv >= err_init) err_init = err_tempv endif - enddo - enddo - - call max_across_PEs(err_init) + enddo ; enddo - write(mesg,*) "ice_shelf_solve_outer: INITIAL nonlinear residual = ", err_init*US%L_to_m - call MOM_mesg(mesg, 5) + call max_across_PEs(err_init) + endif u_last(:,:) = u_shlf(:,:) ; v_last(:,:) = v_shlf(:,:) @@ -949,12 +916,12 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u_shlf, v_shlf, iters, time) do iter=1,100 - call ice_shelf_solve_inner(CS, ISS, G, US, u_shlf, v_shlf, TAUDX, TAUDY, H_node, float_cond, & + call ice_shelf_solve_inner(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, H_node, float_cond, & ISS%hmask, conv_flag, iters, time, Phi, Phisub) if (CS%debug) then - call qchksum(u_shlf, "u shelf", G%HI, haloshift=2, scale=US%L_to_m) - call qchksum(v_shlf, "v shelf", G%HI, haloshift=2, scale=US%L_to_m) + call qchksum(u_shlf, "u shelf", G%HI, haloshift=2, scale=US%L_T_to_m_s) + call qchksum(v_shlf, "v shelf", G%HI, haloshift=2, scale=US%L_T_to_m_s) endif write(mesg,*) "ice_shelf_solve_outer: linear solve done in ",iters," iterations" @@ -962,68 +929,61 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u_shlf, v_shlf, iters, time) call calc_shelf_visc(CS, ISS, G, US, u_shlf, v_shlf) call pass_var(CS%ice_visc, G%domain) - call pass_var(CS%taub_beta_eff, G%domain) + call pass_var(CS%basal_traction, 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%ground_frac(i,j) + CS%basal_traction(i,j) = CS%basal_traction(i,j) * CS%ground_frac(i,j) enddo ; enddo u_bdry_cont(:,:) = 0 ; v_bdry_cont(:,:) = 0 call apply_boundary_values(CS, ISS, G, US, time, Phisub, H_node, CS%ice_visc, & - CS%taub_beta_eff, float_cond, & + CS%basal_traction, float_cond, & rhoi_rhow, u_bdry_cont, v_bdry_cont) Au(:,:) = 0 ; Av(:,:) = 0 call CG_action(Au, Av, u_shlf, v_shlf, Phi, Phisub, CS%umask, CS%vmask, ISS%hmask, H_node, & - CS%ice_visc, float_cond, G%bathyT, CS%taub_beta_eff, G%areaT, & + CS%ice_visc, float_cond, G%bathyT, CS%basal_traction, G%areaT, & G, US, 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 + do J=G%jscB,G%jecB ; do I=G%jscB,G%iecB + if (CS%umask(I,J) == 1) then + err_tempu = ABS(Au(I,J) + u_bdry_cont(I,J) - taudx(I,J)) + if (err_tempu >= err_max) err_max = err_tempu + endif + if (CS%vmask(I,J) == 1) then + err_tempv = ABS(Av(I,J) + v_bdry_cont(I,J) - taudy(I,J)) + if (err_tempv >= err_max) 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_shlf(I,J)) - tempu = u_shlf(I,J) - endif - if (CS%vmask(i,j) == 1) then - err_tempv = MAX(ABS(v_last(i,j)-v_shlf(I,J)), err_tempu) - tempv = SQRT(v_shlf(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 + do J=G%jscB,G%jecB ; do I=G%iscB,G%iecB + if (CS%umask(i,j) == 1) then + err_tempu = ABS(u_last(I,J)-u_shlf(I,J)) + if (err_tempu >= err_max) err_max = err_tempu + tempu = u_shlf(I,J) + else + tempu = 0.0 + endif + if (CS%vmask(I,J) == 1) then + err_tempv = MAX(ABS(v_last(I,J)-v_shlf(I,J)), err_tempu) + if (err_tempv >= err_max) err_max = err_tempv + tempv = SQRT(v_shlf(I,J)**2 + tempu**2) + endif + if (tempv >= max_vel) max_vel = tempv + enddo ; enddo u_last(:,:) = u_shlf(:,:) v_last(:,:) = v_shlf(:,:) @@ -1031,10 +991,9 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u_shlf, v_shlf, iters, time) call max_across_PEs(max_vel) call max_across_PEs(err_max) err_init = max_vel - endif - write(mesg,*) "ice_shelf_solve_outer: nonlinear residual = ", err_max/err_init + write(mesg,*) "ice_shelf_solve_outer: nonlinear fractional residual = ", err_max/err_init call MOM_mesg(mesg, 5) if (err_max <= CS%nonlinear_tolerance * err_init) then @@ -1058,14 +1017,13 @@ subroutine ice_shelf_solve_inner(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, H type(ocean_grid_type), intent(inout) :: G !< The grid structure used by the ice shelf. type(unit_scale_type), intent(in) :: US !< A structure containing unit conversion factors real, dimension(SZDIB_(G),SZDJB_(G)), & - intent(inout) :: u_shlf !< The zonal ice shelf velocity at vertices [L yr-1 ~> m yr-1] + intent(inout) :: u_shlf !< The zonal ice shelf velocity at vertices [L T-1 ~> m s-1] real, dimension(SZDIB_(G),SZDJB_(G)), & - intent(inout) :: v_shlf !< The meridional ice shelf velocity at vertices [L yr-1 ~> m yr-1] + intent(inout) :: v_shlf !< The meridional ice shelf velocity at vertices [L T-1 ~> m s-1] real, dimension(SZDIB_(G),SZDJB_(G)), & - intent(in) :: taudx !< The x-direction driving stress, in [kg L s-2 ~> kg m s-2] + intent(in) :: taudx !< The x-direction driving stress [R L3 Z T-2 ~> kg m s-2] real, dimension(SZDIB_(G),SZDJB_(G)), & - intent(in) :: taudy !< The y-direction driving stress, in [kg L s-2 ~> kg m s-2] - ! This will become [R L3 Z T-2 ~> kg m s-2] + intent(in) :: taudy !< The y-direction driving stress [R L3 Z T-2 ~> kg m s-2] real, dimension(SZDIB_(G),SZDJB_(G)), & intent(in) :: H_node !< The ice shelf thickness at nodal (corner) !! points [Z ~> m]. @@ -1092,27 +1050,30 @@ subroutine ice_shelf_solve_inner(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, H ! 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 +! assumed - u, v, taud, visc, basal_traction are valid on the halo real, dimension(SZDIB_(G),SZDJB_(G)) :: & - Ru, Rv, & ! Residuals in the stress calculations [L kg s-2 ~> m kg s-2] - Ru_old, Rv_old, & - Zu, Zv, & ! Contributions to velocity changes [L yr-1 ~> m yr-1]? - Zu_old, Zv_old, & ! Previous values of Zu and Zv [L yr-1 ~> m yr-1]? - DIAGu, DIAGv, & - RHSu, RHSv, & ! Right hand side of the stress balance [L kg s-2 ~> m kg s-2] - ubd, vbd, & ! Boundary stress contributions [L kg s-2 ~> m kg s-2] - Au, Av, & - Du, Dv, & ! Velocity changes [L yr-1 ~> m yr-1] + Ru, Rv, & ! Residuals in the stress calculations [R L3 Z T-2 ~> m kg s-2] + Ru_old, Rv_old, & ! Previous values of Ru and Rv [R L3 Z T-2 ~> m kg s-2] + Zu, Zv, & ! Contributions to velocity changes [L T-1 ~> m s-1] + Zu_old, Zv_old, & ! Previous values of Zu and Zv [L T-1 ~> m s-1] + DIAGu, DIAGv, & ! Diagonals with units like Ru/Zu [R L2 Z T-1 ~> kg s-1] + RHSu, RHSv, & ! Right hand side of the stress balance [R L3 Z T-2 ~> m kg s-2] + ubd, vbd, & ! Boundary stress contributions [R L3 Z T-2 ~> kg m s-2] + Au, Av, & ! The retarding lateral stress contributions [R L3 Z T-2 ~> kg m s-2] + Du, Dv, & ! Velocity changes [L T-1 ~> m s-1] sum_vec, sum_vec_2 - 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 + real :: tol, beta_k, area, dot_p1, resid0, cg_halo + real :: num, denom + real :: alpha_k ! A scaling factor for iterative corrections [nondim] real :: resid_scale ! A scaling factor for redimensionalizing the global residuals [m2 L-2 ~> 1] -! character(2) :: gridsize - -! real, dimension(2,2) :: X,Y + ! [m2 L-2 ~> 1] [R L3 Z T-2 ~> m kg s-2] + real :: resid2_scale ! A scaling factor for redimensionalizing the global squared residuals + ! [m2 L-2 ~> 1] [R L3 Z T-2 ~> m kg s-2] + real :: rhoi_rhow ! The density of ice divided by a typical water density [nondim] + integer :: iter, i, j, isd, ied, jsd, jed, isc, iec, jsc, jec, is, js, ie, je + integer :: Is_sum, Js_sum, Ie_sum, Je_sum ! Loop bounds for global sums or arrays starting at 1. + integer :: isdq, iedq, jsdq, jedq, iscq, iecq, jscq, jecq, nx_halo, ny_halo isdq = G%isdB ; iedq = G%iedB ; jsdq = G%jsdB ; jedq = G%jedB iscq = G%iscB ; iecq = G%iecB ; jscq = G%jscB ; jecq = G%jecB @@ -1120,73 +1081,58 @@ subroutine ice_shelf_solve_inner(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, H isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed isc = G%isc ; iec = G%iec ; jsc = G%jsc ; jec = G%jec + rhoi_rhow = CS%density_ice / CS%density_ocean_avg + 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 + dot_p1 = 0 - isumstart = G%isc + ! Determine the loop limits for sums, bearing in mind that the arrays will be starting at 1. + Is_sum = G%isc + (1-G%IsdB) + Ie_sum = G%iecB + (1-G%IsdB) ! 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 + if (G%isc+G%idg_offset==G%isg) Is_sum = G%IscB + (1-G%IsdB) - jsumstart = G%jsc + Js_sum = G%jsc + (1-G%JsdB) + Je_sum = G%jecB + (1-G%JsdB) ! 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 + if (G%jsc+G%jdg_offset==G%jsg) Js_sum = G%JscB + (1-G%JsdB) call apply_boundary_values(CS, ISS, G, US, time, Phisub, H_node, CS%ice_visc, & - CS%taub_beta_eff, float_cond, & - CS%density_ice/CS%density_ocean_avg, ubd, vbd) + CS%basal_traction, float_cond, rhoi_rhow, ubd, vbd) RHSu(:,:) = taudx(:,:) - ubd(:,:) RHSv(:,:) = taudy(:,:) - vbd(:,:) call pass_vector(RHSu, RHSv, G%domain, TO_ALL, BGRID_NE) - call matrix_diagonal(CS, G, US, 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 matrix_diagonal(CS, G, US, float_cond, H_node, CS%ice_visc, CS%basal_traction, & + hmask, rhoi_rhow, Phisub, DIAGu, DIAGv) call pass_vector(DIAGu, DIAGv, G%domain, TO_ALL, BGRID_NE) call CG_action(Au, Av, u_shlf, v_shlf, Phi, Phisub, CS%umask, CS%vmask, hmask, & - H_node, CS%ice_visc, float_cond, G%bathyT, CS%taub_beta_eff, & - G%areaT, G, US, isc-1, iec+1, jsc-1, jec+1, CS%density_ice/CS%density_ocean_avg) + H_node, CS%ice_visc, float_cond, G%bathyT, CS%basal_traction, & + G%areaT, G, US, isc-1, iec+1, jsc-1, jec+1, rhoi_rhow) call pass_vector(Au, Av, G%domain, TO_ALL, BGRID_NE) - Ru(:,:) = RHSu(:,:) - Au(:,:) ; Rv(:,:) = RHSv(:,:) - Av(:,:) - - resid_scale = US%L_to_m**2 - - 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 + resid_scale*Ru(i,j)**2 - if (CS%vmask(i,j) == 1) dot_p1 = dot_p1 + resid_scale*Rv(i,j)**2 - enddo - enddo - - call sum_across_PEs(dot_p1) - - else + Ru(:,:) = (RHSu(:,:) - Au(:,:)) + Rv(:,:) = (RHSv(:,:) - Av(:,:)) - sum_vec(:,:) = 0.0 + resid_scale = US%L_to_m**2*US%s_to_T*US%RZ_to_kg_m2*US%L_T_to_m_s**2 + resid2_scale = (US%RZ_to_kg_m2*US%L_to_m*US%L_T_to_m_s**2)**2 - do j=jsumstart,jecq - do i=isumstart,iecq - if (CS%umask(i,j) == 1) sum_vec(i,j) = resid_scale*Ru(i,j)**2 - if (CS%vmask(i,j) == 1) sum_vec(i,j) = sum_vec(i,j) + resid_scale*Rv(i,j)**2 - enddo - enddo + sum_vec(:,:) = 0.0 + do j=jscq,jecq ; do i=iscq,iecq + if (CS%umask(i,j) == 1) sum_vec(i,j) = resid2_scale*Ru(i,j)**2 + if (CS%vmask(i,j) == 1) sum_vec(i,j) = sum_vec(i,j) + resid2_scale*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) ) + dot_p1 = reproducing_sum( sum_vec, Js_sum, Ie_sum, Js_sum, Je_sum ) - endif - - resid0 = sqrt (dot_p1) + resid0 = sqrt(dot_p1) do j=jsdq,jedq do i=isdq,iedq @@ -1206,8 +1152,6 @@ subroutine ice_shelf_solve_inner(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, H !! !! !!!!!!!!!!!!!!!!!! - - ! initially, c-grid data is valid up to 3 halo nodes out do iter = 1,CS%cg_max_iterations @@ -1223,69 +1167,42 @@ subroutine ice_shelf_solve_inner(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, H 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, US, is, ie, js, je, CS%density_ice/CS%density_ocean_avg) + H_node, CS%ice_visc, float_cond, G%bathyT, CS%basal_traction, & + G%areaT, G, US, is, ie, js, je, rhoi_rhow) ! 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 + resid_scale*Zu(i,j)*Ru(i,j) - dot_p2 = dot_p2 + resid_scale*Du(i,j)*Au(i,j) - endif - if (CS%vmask(i,j) == 1) then - dot_p1 = dot_p1 + resid_scale*Zv(i,j)*Rv(i,j) - dot_p2 = dot_p2 + resid_scale*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) = resid_scale*Zu(i,j) * Ru(i,j) - if (CS%vmask(i,j) == 1) sum_vec(i,j) = sum_vec(i,j) + resid_scale*Zv(i,j) * Rv(i,j) + sum_vec(:,:) = 0.0 ; sum_vec_2(:,:) = 0.0 - if (CS%umask(i,j) == 1) sum_vec_2(i,j) = resid_scale*Du(i,j) * Au(i,j) - if (CS%vmask(i,j) == 1) sum_vec_2(i,j) = sum_vec_2(i,j) + resid_scale*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) ) + do j=jscq,jecq ; do i=iscq,iecq + if (CS%umask(i,j) == 1) then + sum_vec(i,j) = resid_scale * Zu(i,j) * Ru(i,j) + sum_vec_2(i,j) = resid_scale * Du(i,j) * Au(i,j) + endif + if (CS%vmask(i,j) == 1) then + sum_vec(i,j) = sum_vec(i,j) + resid_scale * Zv(i,j) * Rv(i,j) + sum_vec_2(i,j) = sum_vec_2(i,j) + resid_scale * Dv(i,j) * Av(i,j) + endif + enddo ; enddo - 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 = reproducing_sum( sum_vec, Is_sum, Ie_sum, Js_sum, Je_sum ) / & + reproducing_sum( sum_vec_2, Is_sum, Ie_sum, Js_sum, Je_sum ) - alpha_k = dot_p1/dot_p2 - do j=jsd,jed - do i=isd,ied - if (CS%umask(i,j) == 1) u_shlf(I,J) = u_shlf(I,J) + alpha_k * Du(i,j) - if (CS%vmask(i,j) == 1) v_shlf(I,J) = v_shlf(I,J) + alpha_k * Dv(i,j) - enddo - enddo + do j=jsd,jed ; do i=isd,ied + if (CS%umask(i,j) == 1) u_shlf(I,J) = u_shlf(I,J) + alpha_k * Du(i,j) + if (CS%vmask(i,j) == 1) v_shlf(I,J) = v_shlf(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 + 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(:,:) @@ -1297,7 +1214,6 @@ subroutine ice_shelf_solve_inner(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, H enddo enddo - do j=jsdq,jedq do i=isdq,iedq if (CS%umask(i,j) == 1) then @@ -1311,50 +1227,22 @@ subroutine ice_shelf_solve_inner(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, H ! 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 + resid_scale*Zu(i,j)*Ru(i,j) - dot_p2 = dot_p2 + resid_scale*Zu_old(i,j)*Ru_old(i,j) - endif - if (CS%vmask(i,j) == 1) then - dot_p1 = dot_p1 + resid_scale*Zv(i,j)*Rv(i,j) - dot_p2 = dot_p2 + resid_scale*Zv_old(i,j)*Rv_old(i,j) - endif - enddo - enddo - call sum_across_PEs(dot_p1) ; call sum_across_PEs(dot_p2) - + sum_vec(:,:) = 0.0 ; sum_vec_2(:,:) = 0.0 - 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) = resid_scale*Zu(i,j) * Ru(i,j) - if (CS%vmask(i,j) == 1) sum_vec(i,j) = sum_vec(i,j) + resid_scale*Zv(i,j) * Rv(i,j) - - if (CS%umask(i,j) == 1) sum_vec_2(i,j) = resid_scale*Zu_old(i,j) * Ru_old(i,j) - if (CS%vmask(i,j) == 1) sum_vec_2(i,j) = sum_vec_2(i,j) + resid_scale*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 + do j=jscq,jecq ; do i=iscq,iecq + if (CS%umask(i,j) == 1) then + sum_vec(i,j) = resid_scale * Zu(i,j) * Ru(i,j) + sum_vec_2(i,j) = resid_scale * Zu_old(i,j) * Ru_old(i,j) + endif + if (CS%vmask(i,j) == 1) then + sum_vec(i,j) = sum_vec(i,j) + resid_scale * Zv(i,j) * Rv(i,j) + sum_vec_2(i,j) = sum_vec_2(i,j) + resid_scale * Zv_old(i,j) * Rv_old(i,j) + endif + enddo ; enddo + beta_k = reproducing_sum(sum_vec, Is_sum, Ie_sum, Js_sum, Je_sum ) / & + reproducing_sum(sum_vec_2, Is_sum, Ie_sum, Js_sum, Je_sum ) ! Du(:,:) = Zu(:,:) + beta_k * Du(:,:) ! Dv(:,:) = Zv(:,:) + beta_k * Dv(:,:) @@ -1368,38 +1256,14 @@ subroutine ice_shelf_solve_inner(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, H ! 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 + resid_scale*Ru(i,j)**2 - endif - if (CS%vmask(i,j) == 1) then - dot_p1 = dot_p1 + resid_scale*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) = resid_scale*Ru(i,j)**2 - if (CS%vmask(i,j) == 1) sum_vec(i,j) = sum_vec(i,j) + resid_scale*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 + sum_vec(:,:) = 0.0 + do j=jscq,jecq ; do i=iscq,iecq + if (CS%umask(i,j) == 1) sum_vec(i,j) = resid2_scale*Ru(i,j)**2 + if (CS%vmask(i,j) == 1) sum_vec(i,j) = sum_vec(i,j) + resid2_scale*Rv(i,j)**2 + enddo ; enddo - dot_p1 = sqrt (dot_p1) + dot_p1 = reproducing_sum( sum_vec, Is_sum, Ie_sum, Js_sum, Je_sum ) + dot_p1 = sqrt(dot_p1) if (dot_p1 <= CS%cg_tolerance * resid0) then iters = iter @@ -1446,7 +1310,7 @@ 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 [s]. + real, intent(in) :: time_step !< The time step for this update [T ~> 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 @@ -1481,7 +1345,7 @@ subroutine ice_shelf_advect_thickness_x(CS, G, time_step, hmask, h0, h_after_ufl 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 ! Thicknesses [Z ~> m]. - real :: u_face ! Zonal velocity at a face, positive if out {L s-1 ~> m s-1] + real :: u_face ! Zonal velocity at a face, positive if out {L Z-1 ~> m s-1] real :: flux_diff_cell real :: slope_lim ! The value of the slope limiter, in the range of 0 to 2 [nondim] character (len=1) :: debug_str @@ -1675,7 +1539,7 @@ 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 [s]. + real, intent(in) :: time_step !< The time step for this update [T ~> 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 @@ -1711,7 +1575,7 @@ subroutine ice_shelf_advect_thickness_y(CS, G, time_step, hmask, h_after_uflux, 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 ! Thicknesses [Z ~> m]. - real :: v_face ! Pseudo-meridional velocity at a cell face, positive if out {L s-1 ~> m s-1] + real :: v_face ! Pseudo-meridional velocity at a cell face, positive if out {L T-1 ~> m s-1] real :: flux_diff_cell real :: slope_lim ! The value of the slope limiter, in the range of 0 to 2 [nondim] character(len=1) :: debug_str @@ -2107,7 +1971,7 @@ subroutine calve_to_mask(G, h_shelf, area_shelf_h, hmask, calve_mask) end subroutine calve_to_mask -subroutine calc_shelf_driving_stress(CS, ISS, G, US, taud_x, taud_y, OD) +subroutine calc_shelf_driving_stress(CS, ISS, G, US, taudx, taudy, 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 @@ -2116,14 +1980,14 @@ subroutine calc_shelf_driving_stress(CS, ISS, G, US, taud_x, taud_y, OD) real, dimension(SZDI_(G),SZDJ_(G)), & intent(in) :: OD !< ocean floor depth at tracer points [Z ~> m]. real, dimension(SZDIB_(G),SZDJB_(G)), & - intent(inout) :: taud_x !< X-direction driving stress at q-points [kg L s-2 ~> kg m s-2] + intent(inout) :: taudx !< X-direction driving stress at q-points [kg L s-2 ~> kg m s-2] real, dimension(SZDIB_(G),SZDJB_(G)), & - intent(inout) :: taud_y !< Y-direction driving stress at q-points [kg L s-2 ~> kg m s-2] + intent(inout) :: taudy !< Y-direction driving stress at q-points [kg L s-2 ~> kg m s-2] ! This will become [R L3 Z T-2 ~> kg m s-2] ! driving stress! -! ! TAUD_X and TAUD_Y will hold driving stress in the x- and y- directions when done. +! ! taudx and taudy 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 @@ -2141,8 +2005,6 @@ subroutine calc_shelf_driving_stress(CS, ISS, G, US, taud_x, taud_y, OD) real :: neumann_val ! [R Z L2 T-2 ~> kg s-2] real :: dxh, dyh ! Local grid spacing [L ~> m] real :: grav ! The gravitational acceleration [L2 Z-1 T-2 ~> m s-2] - real :: taud_scale ! The conversion factor from scaled to MKS units for taud_x and - ! taud_y [kg s-2 R-1 L-2 Z-1 T2 ~> 1] integer :: i, j, iscq, iecq, jscq, jecq, isd, jsd, is, js, iegq, jegq integer :: giec, gjec, gisc, gjsc, cnt, isc, jsc, iec, jec @@ -2160,7 +2022,6 @@ subroutine calc_shelf_driving_stress(CS, ISS, G, US, taud_x, taud_y, OD) rho = CS%density_ice rhow = CS%density_ocean_avg grav = CS%g_Earth - taud_scale = US%R_to_kg_m3*US%Z_to_m**US%L_T_to_m_s**2 ! prelim - go through and calculate S @@ -2247,20 +2108,20 @@ subroutine calc_shelf_driving_stress(CS, ISS, G, US, taud_x, taud_y, OD) endif ! SW vertex - taud_x(I-1,J-1) = taud_x(I-1,J-1) - .25 * rho * taud_scale * grav * ISS%h_shelf(i,j) * sx * G%areaT(i,j) - taud_y(I-1,J-1) = taud_y(I-1,J-1) - .25 * rho * taud_scale * grav * ISS%h_shelf(i,j) * sy * G%areaT(i,j) + taudx(I-1,J-1) = taudx(I-1,J-1) - .25 * rho * grav * ISS%h_shelf(i,j) * sx * G%areaT(i,j) + taudy(I-1,J-1) = taudy(I-1,J-1) - .25 * rho * grav * ISS%h_shelf(i,j) * sy * G%areaT(i,j) ! SE vertex - taud_x(I,J-1) = taud_x(I,J-1) - .25 * rho * taud_scale * grav * ISS%h_shelf(i,j) * sx * G%areaT(i,j) - taud_y(I,J-1) = taud_y(I,J-1) - .25 * rho * taud_scale * grav * ISS%h_shelf(i,j) * sy * G%areaT(i,j) + taudx(I,J-1) = taudx(I,J-1) - .25 * rho * grav * ISS%h_shelf(i,j) * sx * G%areaT(i,j) + taudy(I,J-1) = taudy(I,J-1) - .25 * rho * grav * ISS%h_shelf(i,j) * sy * G%areaT(i,j) ! NW vertex - taud_x(I-1,J) = taud_x(I-1,J) - .25 * rho * taud_scale * grav * ISS%h_shelf(i,j) * sx * G%areaT(i,j) - taud_y(I-1,J) = taud_y(I-1,J) - .25 * rho * taud_scale * grav * ISS%h_shelf(i,j) * sy * G%areaT(i,j) + taudx(I-1,J) = taudx(I-1,J) - .25 * rho * grav * ISS%h_shelf(i,j) * sx * G%areaT(i,j) + taudy(I-1,J) = taudy(I-1,J) - .25 * rho * grav * ISS%h_shelf(i,j) * sy * G%areaT(i,j) ! NE vertex - taud_x(I,J) = taud_x(I,J) - .25 * rho * taud_scale * grav * ISS%h_shelf(i,j) * sx * G%areaT(i,j) - taud_y(I,J) = taud_y(I,J) - .25 * rho * taud_scale * grav * ISS%h_shelf(i,j) * sy * G%areaT(i,j) + taudx(I,J) = taudx(I,J) - .25 * rho * grav * ISS%h_shelf(i,j) * sx * G%areaT(i,j) + taudy(I,J) = taudy(I,J) - .25 * rho * grav * ISS%h_shelf(i,j) * sy * G%areaT(i,j) if (CS%ground_frac(i,j) == 1) then neumann_val = .5 * grav * (rho * ISS%h_shelf(i,j)**2 - rhow * G%bathyT(i,j)**2) @@ -2278,26 +2139,26 @@ subroutine calc_shelf_driving_stress(CS, ISS, G, US, taud_x, taud_y, OD) ! is not above the base of the ice in the current cell ! Note the negative sign due to the direction of the normal vector - taud_x(i-1,j-1) = taud_x(i-1,j-1) - .5 * taud_scale * dyh * neumann_val - taud_x(i-1,j) = taud_x(i-1,j) - .5 * taud_scale * dyh * neumann_val + taudx(I-1,J-1) = taudx(I-1,J-1) - .5 * dyh * neumann_val + taudx(I-1,J) = taudx(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 * taud_scale * dyh * neumann_val - taud_x(i,j) = taud_x(i,j) + .5 * taud_scale * dyh * neumann_val + taudx(I,J-1) = taudx(I,J-1) + .5 * dyh * neumann_val + taudx(I,J) = taudx(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 * taud_scale * dxh * neumann_val - taud_y(i,j-1) = taud_y(i,j-1) - .5 * taud_scale * dxh * neumann_val + taudy(I-1,J-1) = taudy(I-1,J-1) - .5 * dxh * neumann_val + taudy(I,J-1) = taudy(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 * taud_scale * dxh * neumann_val - taud_y(i,j) = taud_y(i,j) + .5 * taud_scale * dxh * neumann_val + taudy(I-1,J) = taudy(I-1,J) + .5 * dxh * neumann_val + taudy(I,J) = taudy(I,J) + .5 * dxh * neumann_val endif endif @@ -2314,7 +2175,7 @@ subroutine init_boundary_values(CS, G, time, hmask, input_flux, input_thick, new 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 per - !! unit face length [Z L s-1 ~> m2 s-1] + !! unit face length [Z L T-1 ~> m2 s-1] real, intent(in) :: input_thick !< The ice thickness at boundaries [Z ~> m]. logical, optional, intent(in) :: new_sim !< If present and false, this run is being restarted @@ -2325,20 +2186,14 @@ subroutine init_boundary_values(CS, G, time, hmask, input_flux, input_thick, new ! 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 :: i, j , isd, jsd, ied, jed 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 @@ -2379,13 +2234,13 @@ end subroutine init_boundary_values subroutine CG_action(uret, vret, u_shlf, v_shlf, Phi, Phisub, umask, vmask, hmask, H_node, & - nu, float_cond, bathyT, beta, dxdyh, G, US, is, ie, js, je, dens_ratio) + ice_visc, float_cond, bathyT, basal_trac, dxdyh, G, US, 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. [L ? ~> m ?] + intent(inout) :: uret !< The retarding stresses working at u-points [R L3 Z T-2 ~> kg m s-2]. real, dimension(G%IsdB:G%IedB,G%JsdB:G%JedB), & - intent(inout) :: vret !< The retarding stresses working at v-points. [L ? ~> m ?] + intent(inout) :: vret !< The retarding stresses working at v-points [R L3 Z T-2 ~> kg m s-2]. 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 [L-1 ~> m-1]. @@ -2393,9 +2248,9 @@ subroutine CG_action(uret, vret, u_shlf, v_shlf, Phi, Phisub, umask, vmask, hmas intent(in) :: Phisub !< Quadrature structure weights at subgridscale !! locations for finite element calculations [nondim] real, dimension(SZDIB_(G),SZDJB_(G)), & - intent(in) :: u_shlf !< The zonal ice shelf velocity at vertices [L yr-1 ~> m yr-1] + intent(in) :: u_shlf !< The zonal ice shelf velocity at vertices [L T-1 ~> m s-1] real, dimension(SZDIB_(G),SZDJB_(G)), & - intent(in) :: v_shlf !< The meridional ice shelf velocity at vertices [L yr-1 ~> m yr-1] + intent(in) :: v_shlf !< The meridional ice shelf velocity at vertices [L T-1 ~> m s-1] real, dimension(SZDIB_(G),SZDJB_(G)), & intent(in) :: umask !< A coded mask indicating the nature of the !! zonal flow at the corner point @@ -2409,7 +2264,7 @@ subroutine CG_action(uret, vret, u_shlf, v_shlf, Phi, Phisub, umask, vmask, hmas 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 + intent(in) :: ice_visc !< 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)), & @@ -2418,7 +2273,7 @@ subroutine CG_action(uret, vret, u_shlf, v_shlf, Phi, Phisub, umask, vmask, hmas real, dimension(SZDI_(G),SZDJ_(G)), & intent(in) :: bathyT !< The depth of ocean bathymetry at tracer points [Z ~> m]. real, dimension(SZDIB_(G),SZDJB_(G)), & - intent(in) :: beta !< A field related to the nonlinear part of the + intent(in) :: basal_trac !< A field related to the nonlinear part of the !! "linearized" basal stress. The exact form and !! units depend on the basal law exponent. [L-2 ? ~> m-2 ?] ! and/or whether flow is "hybridized" @@ -2451,34 +2306,16 @@ subroutine CG_action(uret, vret, u_shlf, v_shlf, Phi, Phisub, umask, vmask, hmas ! 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, basel - real :: area + real :: ux, uy, vx, vy ! Components of velocity shears or divergence [T-1 ~> s-1] + real :: uq, vq ! Interpolated velocities [L T-1 ~> m s-1] 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)*US%m_to_L -! Y(:,:) = G%geoLatBu(i-1:i,j-1:j)*US%m_to_L -! -! call bilinear_shape_functions(X, Y, Phi, area) + do j=js,je ; do i=is,ie ; if (hmask(i,j) == 1) then - ! 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 uq = u_shlf(i-1,j-1) * xquad(3-iq) * xquad(3-jq) + & @@ -2513,13 +2350,13 @@ subroutine CG_action(uret, vret, u_shlf, v_shlf, Phi, Phisub, umask, vmask, hmas 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) + & - 0.25 * area * nu(i,j) * ((4*ux+2*vy) * Phi(i,j,2*(2*(jphi-1)+iphi)-1,2*(jq-1)+iq) + & + uret(i-2+iphi,j-2+jphi) = uret(i-2+iphi,j-2+jphi) + 0.25 * dxdyh(i,j) * ice_visc(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) + & - 0.25 * area * nu(i,j) * ((uy+vx) * Phi(i,j,2*(2*(jphi-1)+iphi)-1,2*(jq-1)+iq) + & + vret(i-2+iphi,j-2+jphi) = vret(i-2+iphi,j-2+jphi) + 0.25 * dxdyh(i,j) * ice_visc(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 @@ -2528,13 +2365,13 @@ subroutine CG_action(uret, vret, u_shlf, v_shlf, Phi, Phisub, umask, vmask, hmas jlq = 1 ; if (jq == jphi) jlq = 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) + & - 0.25 * beta(i,j) * area * uq * xquad(ilq) * xquad(jlq) + uret(i-2+iphi,j-2+jphi) = uret(i-2+iphi,j-2+jphi) + & + 0.25 * basal_trac(i,j) * dxdyh(i,j) * 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) + & - 0.25 * beta(i,j) * area * vq * xquad(ilq) * xquad(jlq) + vret(i-2+iphi,j-2+jphi) = vret(i-2+iphi,j-2+jphi) + & + 0.25 * basal_trac(i,j) * dxdyh(i,j) * vq * xquad(ilq) * xquad(jlq) endif endif @@ -2542,22 +2379,21 @@ subroutine CG_action(uret, vret, u_shlf, v_shlf, Phi, Phisub, umask, vmask, hmas enddo ; enddo if (float_cond(i,j) == 1) then - Usubcontr = 0.0 ; Vsubcontr = 0.0 ; basel = bathyT(i,j) + Usubcontr = 0.0 ; Vsubcontr = 0.0 Ucell(:,:) = u_shlf(i-1:i,j-1:j) ; Vcell(:,:) = v_shlf(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, & + call CG_action_subgrid_basal(Phisub, Hcell, Ucell, Vcell, dxdyh(i,j), bathyT(i,j), & 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) + uret(i-2+iphi,j-2+jphi) = uret(i-2+iphi,j-2+jphi) + Usubcontr(iphi,jphi) * basal_trac(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) + vret(i-2+iphi,j-2+jphi) = vret(i-2+iphi,j-2+jphi) + Vsubcontr(iphi,jphi) * basal_trac(i,j) endif enddo ; enddo endif - endif - enddo ; enddo + endif ; enddo ; enddo end subroutine CG_action @@ -2566,62 +2402,44 @@ subroutine CG_action_subgrid_basal(Phisub, H, U, V, DXDYH, bathyT, dens_ratio, U intent(in) :: Phisub !< Quadrature structure weights at subgridscale !! locations for finite element calculations [nondim] real, dimension(2,2), intent(in) :: H !< The ice shelf thickness at nodal (corner) points [Z ~> m]. - real, dimension(2,2), intent(in) :: U !< The zonal ice shelf velocity at vertices [L yr-1 ~> m yr-1] - real, dimension(2,2), intent(in) :: V !< The meridional ice shelf velocity at vertices [L yr-1 ~> m yr-1] + real, dimension(2,2), intent(in) :: U !< The zonal ice shelf velocity at vertices [L T-1 ~> m s-1] + real, dimension(2,2), intent(in) :: V !< The meridional ice shelf velocity at vertices [L T-1 ~> m s-1] real, intent(in) :: DXDYH !< The tracer cell area [L2 ~> m2] real, intent(in) :: bathyT !< The depth of ocean bathymetry at tracer points [Z ~> m]. real, intent(in) :: dens_ratio !< The density of ice divided by the density !! of seawater [nondim] real, dimension(2,2), intent(inout) :: Ucontr !< A field related to the subgridscale contributions to - !! the u-direction basal stress [L3 yr-1 ~> m3 yr-1]. + !! the u-direction basal stress [L3 T-1 ~> m3 s-1]. real, dimension(2,2), intent(inout) :: Vcontr !< A field related to the subgridscale contributions to - !! the v-direction basal stress [L3 yr-1 ~> m3 yr-1]. + !! the v-direction basal stress [L3 T-1 ~> m3 s-1]. real :: subarea ! A sub-cell area [L2 ~> m2] real :: hloc ! The local sub-cell ice thickness [Z ~> m] - real :: uq, vq ! Local velocities [L yr-1 ~> m yr-1] - integer :: nsub, i, j, k, l, qx, qy, m, n + integer :: nsub, i, j, qx, qy, m, n 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 + do n=1,2 ; do m=1,2 + Ucontr(m,n) = 0.0 ; Vcontr(m,n) = 0.0 + do qy=1,2 ; do qx=1,2 ; do j=1,nsub ; do i=1,nsub + hloc = (Phisub(i,j,1,1,qx,qy)*H(1,1) + Phisub(i,j,2,2,qx,qy)*H(2,2)) + & + (Phisub(i,j,1,2,qx,qy)*H(1,2) + Phisub(i,j,2,1,qx,qy)*H(2,1)) + if (dens_ratio * hloc - bathyT > 0) then ! if (.true.) then + Ucontr(m,n) = Ucontr(m,n) + subarea * 0.25 * Phisub(i,j,m,n,qx,qy) * & + ((Phisub(i,j,1,1,qx,qy) * U(1,1) + Phisub(i,j,2,2,qx,qy) * U(2,2)) + & + (Phisub(i,j,1,2,qx,qy) * U(1,2) + Phisub(i,j,2,1,qx,qy) * U(2,1))) + Vcontr(m,n) = Vcontr(m,n) + subarea * 0.25 * Phisub(i,j,m,n,qx,qy) * & + ((Phisub(i,j,1,1,qx,qy) * V(1,1) + Phisub(i,j,2,2,qx,qy) * V(2,2)) + & + (Phisub(i,j,1,2,qx,qy) * V(1,2) + Phisub(i,j,2,1,qx,qy) * V(2,1))) + 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, US, float_cond, H_node, nu, beta, hmask, dens_ratio, & +subroutine matrix_diagonal(CS, G, US, float_cond, H_node, ice_visc, basal_trac, hmask, dens_ratio, & Phisub, u_diagonal, v_diagonal) type(ice_shelf_dyn_CS), intent(in) :: CS !< A pointer to the ice shelf control structure @@ -2634,11 +2452,11 @@ subroutine matrix_diagonal(CS, G, US, float_cond, H_node, nu, beta, hmask, dens_ intent(in) :: H_node !< The ice shelf thickness at nodal !! (corner) points [Z ~> m]. real, dimension(SZDIB_(G),SZDJB_(G)), & - intent(in) :: nu !< A field related to the ice viscosity from Glen's + intent(in) :: ice_visc !< 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 + intent(in) :: basal_trac !< A field related to the nonlinear part of the !! "linearized" basal stress. The exact form and !! units depend on the basal law exponent [L-2 ? ~> m-2 ?] real, dimension(SZDI_(G),SZDJ_(G)), & @@ -2650,115 +2468,83 @@ subroutine matrix_diagonal(CS, G, US, float_cond, H_node, nu, beta, hmask, dens_ !! locations for finite element calculations [nondim] 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 [same units as nu]. + !! matrix from the left-hand side of the solver [R L2 Z T-1 ~> kg s-1] 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 [same units as nu]. + !! matrix from the left-hand side of the solver [R L2 Z T-1 ~> kg s-1] ! 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 - real :: area, uq, vq, basel - real, dimension(8,4) :: Phi ! [L-1 ~> m-1] - real, dimension(4) :: X, Y ! Sub-cell positions [L ~> m] - real, dimension(2) :: xquad - real, dimension(2,2) :: Hcell,Usubcontr,Vsubcontr - + real :: ux, uy, vx, vy ! Interpolated weight gradients [L-1 ~> m-1] + real :: uq, vq + real, dimension(8,4) :: Phi ! Weight gradients [L-1 ~> m-1] + 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 - X(1:2) = G%geoLonBu(i-1:i,j-1)*1000.0*US%m_to_L - X(3:4) = G%geoLonBu(i-1:i,j) *1000.0*US%m_to_L - Y(1:2) = G%geoLatBu(i-1:i,j-1) *1000.0*US%m_to_L - Y(3:4) = G%geoLatBu(i-1:i,j)*1000.0*US%m_to_L - - call bilinear_shape_functions(X, Y, Phi, area) + call bilinear_shape_fn_grid(G, i, j, Phi) - ! 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 iq=1,2 ; do jq=1,2 ; do iphi=1,2 ; do jphi=1,2 - do iphi=1,2 ; do jphi=1,2 + ilq = 1 ; if (iq == iphi) ilq = 2 + jlq = 1 ; if (jq == jphi) jlq = 2 - if (iq == iphi) then - ilq = 2 - else - ilq = 1 - endif + if (CS%umask(i-2+iphi,j-2+jphi) == 1) then - if (jq == jphi) then - jlq = 2 - else - jlq = 1 - endif + 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. - 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) + & - 0.25 * G%areaT(i,j) * nu(i,j) * ((4*ux+2*vy) * Phi(2*(2*(jphi-1)+iphi)-1,2*(jq-1)+iq) + & + u_diagonal(i-2+iphi,j-2+jphi) = u_diagonal(i-2+iphi,j-2+jphi) + & + 0.25 * G%areaT(i,j) * ice_visc(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)) + if (float_cond(i,j) == 0) then 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) + & - 0.25 * beta(i,j) * G%areaT(i,j) * uq * xquad(ilq) * xquad(jlq) - endif - + !### uq seems to be duplicated here. Why not uq**2? + u_diagonal(i-2+iphi,j-2+jphi) = u_diagonal(i-2+iphi,j-2+jphi) + & + 0.25 * basal_trac(i,j) * G%areaT(i,j) * uq * xquad(ilq) * xquad(jlq) endif + endif - if (CS%vmask(i-2+iphi,j-2+jphi) == 1) then + 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. + 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) + & - 0.25 * G%areaT(i,j) * nu(i,j) * ((uy+vx) * Phi(2*(2*(jphi-1)+iphi)-1,2*(jq-1)+iq) + & + v_diagonal(i-2+iphi,j-2+jphi) = v_diagonal(i-2+iphi,j-2+jphi) + & + 0.25 * G%areaT(i,j) * ice_visc(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 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) + & - 0.25 * beta(i,j) * G%areaT(i,j) * vq * xquad(ilq) * xquad(jlq) - endif - + v_diagonal(i-2+iphi,j-2+jphi) = v_diagonal(i-2+iphi,j-2+jphi) + & + 0.25 * basal_trac(i,j) * G%areaT(i,j) * vq * xquad(ilq) * xquad(jlq) endif - enddo ; enddo - enddo ; enddo + endif + enddo ; enddo ; enddo ; enddo + if (float_cond(i,j) == 1) then - Usubcontr = 0.0 ; Vsubcontr = 0.0 ; basel = G%bathyT(i,j) + Usubcontr = 0.0 ; Vsubcontr = 0.0 Hcell(:,:) = H_node(i-1:i,j-1:j) - call CG_diagonal_subgrid_basal(Phisub, Hcell, G%areaT(i,j), basel, dens_ratio, Usubcontr, Vsubcontr) + call CG_diagonal_subgrid_basal(Phisub, Hcell, G%areaT(i,j), G%bathyT(i,j), 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) + u_diagonal(i-2+iphi,j-2+jphi) = u_diagonal(i-2+iphi,j-2+jphi) + Usubcontr(iphi,jphi) * basal_trac(i,j) + v_diagonal(i-2+iphi,j-2+jphi) = v_diagonal(i-2+iphi,j-2+jphi) + Vsubcontr(iphi,jphi) * basal_trac(i,j) endif enddo ; enddo endif @@ -2805,7 +2591,7 @@ subroutine CG_diagonal_subgrid_basal (Phisub, H_node, DXDYH, bathyT, dens_ratio, end subroutine CG_diagonal_subgrid_basal -subroutine apply_boundary_values(CS, ISS, G, US, time, Phisub, H_node, nu, beta, float_cond, & +subroutine apply_boundary_values(CS, ISS, G, US, time, Phisub, H_node, ice_visc, basal_trac, 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 @@ -2821,11 +2607,11 @@ subroutine apply_boundary_values(CS, ISS, G, US, time, Phisub, H_node, nu, beta, intent(in) :: H_node !< The ice shelf thickness at nodal !! (corner) points [Z ~> m]. real, dimension(SZDIB_(G),SZDJB_(G)), & - intent(in) :: nu !< A field related to the ice viscosity from Glen's + intent(in) :: ice_visc !< 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 + intent(in) :: basal_trac !< A field related to the nonlinear part of the !! "linearized" basal stress. The exact form and !! units depend on the basal law exponent [L-2 ~> m-2] real, dimension(SZDI_(G),SZDJ_(G)), & @@ -2834,34 +2620,27 @@ subroutine apply_boundary_values(CS, ISS, G, US, time, Phisub, H_node, nu, beta, 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 [L yr-1 ~> m yr-1] + intent(inout) :: u_bdry_contr !< Zonal force contributions due to the + !! open boundaries [R L3 Z T-2 ~> kg m s-2] real, dimension(SZDIB_(G),SZDJB_(G)), & - intent(inout) :: v_bdry_contr !< Contributions to the zonal ice - !! velocities due to the open boundaries [L yr-1 ~> m yr-1] + intent(inout) :: v_bdry_contr !< Meridional force contributions due to the + !! open boundaries [R L3 Z T-2 ~> kg m s-2] ! 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, uq, vq, area, basel + real :: ux, uy, vx, vy ! Components of velocity shears or divergence [T-1 ~> s-1] + real :: uq, vq ! Interpolated velocities [L T-1 ~> m s-1] + real :: area real, dimension(2,2) :: Ucell,Vcell,Hcell,Usubcontr,Vsubcontr - 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. @@ -2870,17 +2649,8 @@ subroutine apply_boundary_values(CS, ISS, G, US, time, Phisub, H_node, nu, beta, 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 - X(1:2) = G%geoLonBu(i-1:i,j-1)*1000.0*US%m_to_L - X(3:4) = G%geoLonBu(i-1:i,j)*1000.0*US%m_to_L - Y(1:2) = G%geoLatBu(i-1:i,j-1)*1000.0*US%m_to_L - Y(3:4) = G%geoLatBu(i-1:i,j)*1000.0*US%m_to_L - - call bilinear_shape_functions(X, Y, Phi, area) + call bilinear_shape_fn_grid(G, i, j, Phi) - ! 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 @@ -2917,43 +2687,29 @@ subroutine apply_boundary_values(CS, ISS, G, US, time, Phisub, H_node, nu, beta, 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 + ilq = 1 ; if (iq == iphi) ilq = 2 + jlq = 1 ; if (jq == jphi) jlq = 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) + & - 0.25 * G%areaT(i,j) * nu(i,j) * ( (4*ux+2*vy) * Phi(2*(2*(jphi-1)+iphi)-1,2*(jq-1)+iq) + & + 0.25 * G%areaT(i,j) * ice_visc(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) + & - 0.25 * beta(i,j) * G%areaT(i,j) * uq * xquad(ilq) * xquad(jlq) + 0.25 * basal_trac(i,j) * G%areaT(i,j) * 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) + & - 0.25 * G%areaT(i,j) * 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)) + 0.25 * G%areaT(i,j) * ice_visc(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) + & - 0.25 * beta(i,j) * G%areaT(i,j) * vq * xquad(ilq) * xquad(jlq) + 0.25 * basal_trac(i,j) * G%areaT(i,j) * vq * xquad(ilq) * xquad(jlq) endif - endif enddo ; enddo enddo ; enddo @@ -2967,11 +2723,11 @@ subroutine apply_boundary_values(CS, ISS, G, US, time, Phisub, H_node, nu, beta, 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) + Usubcontr(iphi,jphi) * basal_trac(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) + Vsubcontr(iphi,jphi) * basal_trac(i,j) endif enddo ; enddo endif @@ -2989,9 +2745,9 @@ subroutine calc_shelf_visc(CS, ISS, G, US, u_shlf, v_shlf) type(ocean_grid_type), intent(in) :: G !< The grid structure used by the ice shelf. type(unit_scale_type), intent(in) :: US !< A structure containing unit conversion factors real, dimension(G%IsdB:G%IedB,G%JsdB:G%JedB), & - intent(inout) :: u_shlf !< The zonal ice shelf velocity [L yr-1 ~> m yr-1]. + intent(inout) :: u_shlf !< The zonal ice shelf velocity [L T-1 ~> m s-1]. real, dimension(G%IsdB:G%IedB,G%JsdB:G%JedB), & - intent(inout) :: v_shlf !< The meridional ice shelf velocity [L yr-1 ~> m yr-1]. + intent(inout) :: v_shlf !< The meridional ice shelf velocity [L T-1 ~> m s-1]. ! update DEPTH_INTEGRATED viscosity, based on horizontal strain rates - this is for bilinear FEM solve ! so there is an "upper" and "lower" bilinear viscosity @@ -3002,10 +2758,9 @@ subroutine calc_shelf_visc(CS, ISS, G, US, u_shlf, v_shlf) integer :: i, j, iscq, iecq, jscq, jecq, isd, jsd, ied, jed, iegq, jegq integer :: giec, gjec, gisc, gjsc, cnt, isc, jsc, iec, jec, is, js - real :: A, n - real :: ux, uy, vx, vy, eps_min ! Velocity shears [yr-1] - real :: umid, vmid, unorm ! Velocities [L yr-1 ~> m yr-1] - real :: n_basal_friction + real :: Visc_coef, n_g + real :: ux, uy, vx, vy, eps_min ! Velocity shears [T-1 ~> s-1] + real :: umid, vmid, unorm ! Velocities [L T-1 ~> m s-1] isc = G%isc ; jsc = G%jsc ; iec = G%iec ; jec = G%jec iscq = G%iscB ; iecq = G%iecB ; jscq = G%jscB ; jecq = G%jecB @@ -3015,26 +2770,25 @@ subroutine calc_shelf_visc(CS, ISS, G, US, u_shlf, v_shlf) 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 - n_basal_friction = CS%n_basal_friction + n_g = CS%n_glen; eps_min = CS%eps_glen_min + + Visc_coef = US%kg_m2s_to_RZ_T*US%m_to_L*US%Z_to_L*(CS%A_glen_isothermal)**(1./CS%n_glen) do j=jsd+1,jed-1 do i=isd+1,ied-1 if (ISS%hmask(i,j) == 1) then - ux = (u_shlf(i,j) + u_shlf(i,j-1) - u_shlf(i-1,j) - u_shlf(i-1,j-1)) / (2*G%dxT(i,j)) - vx = (v_shlf(i,j) + v_shlf(i,j-1) - v_shlf(i-1,j) - v_shlf(i-1,j-1)) / (2*G%dxT(i,j)) - uy = (u_shlf(i,j) - u_shlf(i,j-1) + u_shlf(i-1,j) - u_shlf(i-1,j-1)) / (2*G%dyT(i,j)) - vy = (v_shlf(i,j) - v_shlf(i,j-1) + v_shlf(i-1,j) - v_shlf(i-1,j-1)) / (2*G%dyT(i,j)) - - 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)) * & - US%Z_to_m*ISS%h_shelf(i,j) - - umid = (u_shlf(i,j) + u_shlf(i,j-1) + u_shlf(i-1,j) + u_shlf(i-1,j-1))/4 - vmid = (v_shlf(i,j) + v_shlf(i,j-1) + v_shlf(i-1,j) + v_shlf(i-1,j-1))/4 - unorm = sqrt (umid**2 + vmid**2 + (eps_min*G%dxT(i,j))**2) - CS%taub_beta_eff(i,j) = US%L_to_m**2*CS%C_basal_friction * (US%L_to_m*unorm)**(n_basal_friction-1) + ux = ((u_shlf(I,J) + u_shlf(I,J-1)) - (u_shlf(I-1,J) + u_shlf(I-1,J-1))) / (2*G%dxT(i,j)) + vx = ((v_shlf(I,J) + v_shlf(I,J-1)) - (v_shlf(I-1,J) + v_shlf(I-1,J-1))) / (2*G%dxT(i,j)) + uy = ((u_shlf(I,J) + u_shlf(I-1,J)) - (u_shlf(I,J-1) + u_shlf(I-1,J-1))) / (2*G%dyT(i,j)) + vy = ((v_shlf(I,J) + v_shlf(I-1,J)) - (v_shlf(I,J-1) + v_shlf(I-1,J-1))) / (2*G%dyT(i,j)) + CS%ice_visc(i,j) = 0.5 * Visc_coef * ISS%h_shelf(i,j) * & + (US%s_to_T**2 * (ux**2 + vy**2 + ux*vy + 0.25*(uy+vx)**2 + eps_min**2))**((1.-n_g)/(2.*n_g)) + + umid = ((u_shlf(I,J) + u_shlf(I-1,J-1)) + (u_shlf(I,J-1) + u_shlf(I-1,J))) * 0.25 + vmid = ((v_shlf(I,J) + v_shlf(I-1,J-1)) + (v_shlf(I,J-1) + v_shlf(I-1,J))) * 0.25 + unorm = sqrt(umid**2 + vmid**2 + (eps_min*G%dxT(i,j))**2) + CS%basal_traction(i,j) = CS%C_basal_friction * (US%L_T_to_m_s*unorm)**(CS%n_basal_fric-1) endif enddo enddo @@ -3110,7 +2864,7 @@ subroutine update_OD_ffrac_uncoupled(CS, G, h_shelf) 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 +!! 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 [L ~> m]. @@ -3151,11 +2905,6 @@ subroutine bilinear_shape_functions (X, Y, Phi, area) 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*) - ! a = (X(2)-X(1)) * (1-yquad(qpoint)) + (X(4)-X(3)) * yquad(qpoint) ! d(x)/d(x*) - ! b = (Y(2)-Y(1)) * (1-yquad(qpoint)) + (Y(4)-Y(3)) * yquad(qpoint) ! d(y)/d(x*) - ! c = (X(3)-X(1)) * (1-xquad(qpoint)) + (X(4)-X(2)) * xquad(qpoint) ! d(x)/d(y*) - ! d = (Y(3)-Y(1)) * (1-xquad(qpoint)) + (Y(4)-Y(2)) * xquad(qpoint) ! d(y)/d(y*) - do node=1,4 xnode = 2-mod(node,2) ; ynode = ceiling(REAL(node)/2) @@ -3182,6 +2931,62 @@ subroutine bilinear_shape_functions (X, Y, Phi, area) end subroutine bilinear_shape_functions +!> This subroutine calculates the gradients of bilinear basis elements that are centered at the +!! vertices of the cell using a locally orthogoal MOM6 grid. Values are calculated at +!! points of gaussian quadrature. +subroutine bilinear_shape_fn_grid(G, i, j, Phi) + type(ocean_grid_type), intent(in) :: G !< The grid structure used by the ice shelf. + integer, intent(in) :: i !< The i-index in the grid to work on. + integer, intent(in) :: j !< The j-index in the grid to work on. + real, dimension(8,4), intent(inout) :: Phi !< The gradients of bilinear basis elements at Gaussian + !! quadrature points surrounding the cell verticies [L-1 ~> m-1]. + +! This subroutine calculates the gradients of bilinear basis elements that +! that are centered at the vertices of the cell. The 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? + + real, dimension(4) :: xquad, yquad ! [nondim] + real :: a, d ! Interpolated grid spacings [L ~> m] + real :: xexp, yexp ! [nondim] + integer :: node, qpoint, xnode, xq, ynode, yq + + 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 = G%dxCv(i,J-1) * (1-yquad(qpoint)) + G%dxCv(i,J) * yquad(qpoint) ! d(x)/d(x*) + d = G%dyCu(I-1,j) * (1-xquad(qpoint)) + G%dyCu(I,j) * xquad(qpoint) ! d(y)/d(y*) + + 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 ) / (a*d) + Phi(2*node,qpoint) = ( a * (2 * ynode - 3) * xexp ) / (a*d) + + enddo + enddo + +end subroutine bilinear_shape_fn_grid + subroutine bilinear_shape_functions_subgrid(Phisub, nsub) real, dimension(nsub,nsub,2,2,2,2), & @@ -3219,33 +3024,17 @@ subroutine bilinear_shape_functions_subgrid(Phisub, nsub) 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 + do j=1,nsub ; do i=1,nsub + x0 = (i-1) * fracx ; y0 = (j-1) * fracx + do qy=1,2 ; do qx=1,2 + x = x0 + fracx*xquad(qx) + y = y0 + fracx*xquad(qy) + Phisub(i,j,1,1,qx,qy) = (1.0-x) * (1.0-y) + Phisub(i,j,1,2,qx,qy) = (1.0-x) * y + Phisub(i,j,2,1,qx,qy) = x * (1.0-y) + Phisub(i,j,2,2,qx,qy) = x * y + enddo ; enddo + enddo ; enddo end subroutine bilinear_shape_functions_subgrid @@ -3462,7 +3251,7 @@ subroutine ice_shelf_dyn_end(CS) deallocate(CS%u_face_mask, CS%v_face_mask) deallocate(CS%umask, CS%vmask) - deallocate(CS%ice_visc, CS%taub_beta_eff) + deallocate(CS%ice_visc, CS%basal_traction) deallocate(CS%OD_rt, CS%OD_av) deallocate(CS%ground_frac, CS%ground_frac_rt) @@ -3474,14 +3263,14 @@ end subroutine ice_shelf_dyn_end !> This subroutine updates the vertically averaged ice shelf temperature. subroutine ice_shelf_temp(CS, ISS, G, US, 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 + 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(unit_scale_type), intent(in) :: US !< A structure containing unit conversion factors - real, intent(in) :: time_step !< The time step for this update [s]. + type(ocean_grid_type), intent(inout) :: G !< The grid structure used by the ice shelf. + type(unit_scale_type), intent(in) :: US !< A structure containing unit conversion factors + real, intent(in) :: time_step !< The time step for this update [T ~> s]. real, dimension(SZDI_(G),SZDJ_(G)), & - intent(in) :: melt_rate !< basal melt rate [R Z T-1 ~> kg m-2 s-1] - type(time_type), intent(in) :: Time !< The current model time + intent(in) :: melt_rate !< basal melt rate [R Z T-1 ~> kg m-2 s-1] + type(time_type), intent(in) :: Time !< The current model time ! 5/23/12 OVS ! This subroutine takes the velocity (on the Bgrid) and timesteps @@ -3517,13 +3306,11 @@ subroutine ice_shelf_temp(CS, ISS, G, US, time_step, melt_rate, Time) ! through the 4 cell boundaries [Z L2 ~> m3]. integer :: isd, ied, jsd, jed, i, j, isc, iec, jsc, jec real :: t_bd, Tsurf - real :: spy ! The amount of time in a year [T ~> s] real :: adot ! A surface heat exchange coefficient [Z T-1 ~> m s-1]. - spy = 365. * 86400. * US%s_to_T ! For now adot and Tsurf are defined here adot=surf acc 0.1m/yr, Tsurf=-20oC, vary them later - adot = 0.1*US%m_to_Z / spy + adot = (0.1/(365.0*86400.0))*US%m_to_Z*US%T_to_s Tsurf = -20.0 isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed @@ -3533,32 +3320,27 @@ subroutine ice_shelf_temp(CS, ISS, G, US, time_step, melt_rate, Time) 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 + 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 enable_averages(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, US%s_to_T*time_step/spy, ISS%hmask, TH, th_after_uflux, flux_enter) - call ice_shelf_advect_temp_y(CS, G, US%s_to_T*time_step/spy, ISS%hmask, th_after_uflux, th_after_vflux, flux_enter) + call ice_shelf_advect_temp_x(CS, G, time_step, ISS%hmask, TH, th_after_uflux, flux_enter) + call ice_shelf_advect_temp_y(CS, G, time_step, ISS%hmask, th_after_uflux, th_after_vflux, flux_enter) do j=jsd,jed do i=isd,ied @@ -3586,10 +3368,11 @@ subroutine ice_shelf_temp(CS, ISS, G, US, time_step, melt_rate, Time) 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 + !### Why is the hard-coded code uncommented and the plausible one commented out? ! CS%t_shelf(i,j) = CS%t_shelf(i,j) + & -! US%s_to_T*time_step*(adot*Tsurf - US%R_to_kg_m3*melt_rate(i,j)*ISS%tfreeze(i,j))/(ISS%h_shelf(i,j)) - CS%t_shelf(i,j) = CS%t_shelf(i,j) + & - US%s_to_T*time_step*(adot*Tsurf - (3.0*US%m_to_Z/spy)*ISS%tfreeze(i,j)) / ISS%h_shelf(i,j) +! time_step*(adot*Tsurf - US%R_to_kg_m3*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.0/(365.0*86400.0))*US%m_to_Z*US%T_to_s)*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 @@ -3616,7 +3399,7 @@ 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 [s]. + real, intent(in) :: time_step !< The time step for this update [T ~> s]. real, dimension(SZDI_(G),SZDJ_(G)), & intent(in) :: hmask !< A mask indicating which tracer points are !! partly or fully covered by an ice-shelf @@ -3651,7 +3434,7 @@ subroutine ice_shelf_advect_temp_x(CS, G, time_step, hmask, h0, h_after_uflux, f 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 ! Zonal velocity at a face, positive if out {L s-1 ~> m s-1] + real :: u_face ! Zonal velocity at a face, positive if out {L T-1 ~> m s-1] real :: flux_diff_cell, phi character (len=1) :: debug_str @@ -3845,7 +3628,7 @@ 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 [s]. + real, intent(in) :: time_step !< The time step for this update [T ~> s]. real, dimension(SZDI_(G),SZDJ_(G)), & intent(in) :: hmask !< A mask indicating which tracer points are !! partly or fully covered by an ice-shelf @@ -3881,7 +3664,7 @@ subroutine ice_shelf_advect_temp_y(CS, G, time_step, hmask, h_after_uflux, h_aft 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 ! Pseudo-meridional velocity at a cell face, positive if out {L s-1 ~> m s-1] + real :: v_face ! Pseudo-meridional velocity at a cell face, positive if out {L T-1 ~> m s-1] real :: flux_diff_cell, phi character(len=1) :: debug_str diff --git a/src/ice_shelf/MOM_ice_shelf_initialize.F90 b/src/ice_shelf/MOM_ice_shelf_initialize.F90 index f34b3c70f4..20479531a8 100644 --- a/src/ice_shelf/MOM_ice_shelf_initialize.F90 +++ b/src/ice_shelf/MOM_ice_shelf_initialize.F90 @@ -247,20 +247,20 @@ end subroutine initialize_ice_thickness_channel ! intent(inout) :: u_face_mask_bdry !< A boundary-type mask at C-grid u faces ! real, dimension(SZIB_(G),SZJ_(G)), & ! intent(inout) :: u_flux_bdry_val !< The boundary thickness flux through -! !! C-grid u faces [L Z s-1 ~> m2 s-1]. +! !! C-grid u faces [L Z T-1 ~> 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 [L Z s-1 ~> m2 s-1]. +! !! C-grid v faces [L Z T-1 ~> m2 s-1]. ! real, dimension(SZIB_(G),SZJB_(G)), & ! intent(inout) :: u_bdry_val !< The zonal ice shelf velocity at open -! !! boundary vertices [m yr-1]. +! !! boundary vertices [L T-1 ~> m s-1]. ! real, dimension(SZIB_(G),SZJB_(G)), & ! intent(inout) :: v_bdry_val !< The meridional ice shelf velocity at open -! !! boundary vertices [m yr-1]. +! !! boundary vertices [L T-1 ~> m s-1]. ! real, dimension(SZDI_(G),SZDJ_(G)), & -! intent(inout) :: h_bdry_val !< The ice shelf thickness at open boundaries +! intent(inout) :: h_bdry_val !< The ice shelf thickness at open boundaries [Z ~> m] ! real, dimension(SZDI_(G),SZDJ_(G)), & ! intent(inout) :: hmask !< A mask indicating which tracer points are ! !! partly or fully covered by an ice-shelf @@ -304,20 +304,20 @@ end subroutine initialize_ice_thickness_channel ! intent(inout) :: u_face_mask_bdry !< A boundary-type mask at C-grid u faces ! real, dimension(SZIB_(G),SZJ_(G)), & ! intent(inout) :: u_flux_bdry_val !< The boundary thickness flux through -! !! C-grid u faces [L Z s-1 ~> m2 s-1]. +! !! C-grid u faces [L Z T-1 ~> 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 [L Z s-1 ~> m2 s-1]. +! !! C-grid v faces [L Z T-1 ~> m2 s-1]. ! real, dimension(SZIB_(G),SZJB_(G)), & ! intent(inout) :: u_bdry_val !< The zonal ice shelf velocity at open - !! boundary vertices [m yr-1]. + !! boundary vertices [L T-1 ~> m s-1]. ! real, dimension(SZIB_(G),SZJB_(G)), & ! intent(inout) :: v_bdry_val !< The meridional ice shelf velocity at open - !! boundary vertices [m yr-1]. + !! boundary vertices [L T-1 ~> m s-1]. ! real, dimension(SZDI_(G),SZDJ_(G)), & -! intent(inout) :: h_bdry_val !< The ice shelf thickness at open boundaries +! intent(inout) :: h_bdry_val !< The ice shelf thickness at open boundaries [Z ~> m] ! real, dimension(SZDI_(G),SZDJ_(G)), & ! intent(inout) :: hmask !< A mask indicating which tracer points are ! !! partly or fully covered by an ice-shelf @@ -327,18 +327,18 @@ end subroutine initialize_ice_thickness_channel ! 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 -! real :: input_thick -! real :: input_flux ! The input ice flux per unit length [L Z t-1 ~> m2 s-1] +! real :: input_thick ! The input ice shelf thickness [Z ~> m] +! real :: input_flux ! The input ice flux per unit length [L Z T-1 ~> m2 s-1] ! real :: lenlat, len_stress ! call get_param(PF, mdl, "LENLAT", lenlat, fail_if_missing=.true.) ! call get_param(PF, mdl, "INPUT_FLUX_ICE_SHELF", input_flux, & ! "volume flux at upstream boundary", & -! units="m2 s-1", default=0., scale=US%m_to_L*US%m_to_Z) +! units="m2 s-1", default=0., scale=US%m_s_to_L_T*US%m_to_Z) ! call get_param(PF, mdl, "INPUT_THICK_ICE_SHELF", input_thick, & ! "flux thickness at upstream boundary", & -! units="m", default=1000.) +! units="m", default=1000., scale=US%m_to_Z) ! call get_param(PF, mdl, "LEN_SIDE_STRESS", len_stress, & ! "maximum position of no-flow condition in along-flow direction", & ! units="km", default=0.) From 185b42e945d4241568f6a5354e9d80c6129f5a8b Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 26 Mar 2020 05:51:52 -0400 Subject: [PATCH 124/316] +Renamed solo_time_step to solo_step_ice_shelf Renamed to routine to step the ice shelf without an ocean model to solo_step_ice_shelf for greater clarity, and change the time interval argument into a time_type variable. Also added dimensional rescaling of the internal real time variables in solo_step_ice_shelf. All answers are bitwise identical in the MOM6-examples test cases, but it should be noted that there are no active tests of the ice shelf dynamics code. --- .../ice_solo_driver/ice_shelf_driver.F90 | 4 +- src/ice_shelf/MOM_ice_shelf.F90 | 66 +++++++++---------- 2 files changed, 32 insertions(+), 38 deletions(-) diff --git a/config_src/ice_solo_driver/ice_shelf_driver.F90 b/config_src/ice_solo_driver/ice_shelf_driver.F90 index 828dbf301c..f2c5099544 100644 --- a/config_src/ice_solo_driver/ice_shelf_driver.F90 +++ b/config_src/ice_solo_driver/ice_shelf_driver.F90 @@ -50,7 +50,7 @@ program SHELF_main use MOM_write_cputime, only : write_cputime_start_clock, write_cputime_CS use MOM_ice_shelf, only : initialize_ice_shelf, ice_shelf_end, ice_shelf_CS - use MOM_ice_shelf, only : ice_shelf_save_restart, solo_time_step + use MOM_ice_shelf, only : ice_shelf_save_restart, solo_step_ice_shelf ! , add_shelf_flux_forcing, add_shelf_flux_IOB implicit none @@ -330,7 +330,7 @@ program SHELF_main ! This call steps the model over a time time_step. Time1 = Master_Time ; Time = Master_Time - call solo_time_step (ice_shelf_CSp, time_step, m, Time) + call solo_step_ice_shelf(ice_shelf_CSp, Time_step_shelf, m, Time) ! Time = Time + Time_step_ocean ! This is here to enable fractional-second time steps. diff --git a/src/ice_shelf/MOM_ice_shelf.F90 b/src/ice_shelf/MOM_ice_shelf.F90 index cd3ba3fd44..d05631c621 100644 --- a/src/ice_shelf/MOM_ice_shelf.F90 +++ b/src/ice_shelf/MOM_ice_shelf.F90 @@ -8,8 +8,8 @@ module MOM_ice_shelf use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end use MOM_cpu_clock, only : CLOCK_COMPONENT, CLOCK_ROUTINE use MOM_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_diag_mediator, only : diag_mediator_init, set_diag_mediator_grid, diag_ctrl, time_type +use MOM_diag_mediator, only : enable_averages, 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_dyn_horgrid, only : dyn_horgrid_type, create_dyn_horgrid, destroy_dyn_horgrid @@ -26,7 +26,7 @@ module MOM_ice_shelf 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 -use MOM_time_manager, only : time_type, time_type_to_real, time_type_to_real, real_to_time +use MOM_time_manager, only : time_type, time_type_to_real, real_to_time use MOM_transcribe_grid, only : copy_dyngrid_to_MOM_grid, copy_MOM_grid_to_dyngrid use MOM_unit_scaling, only : unit_scale_type, unit_scaling_init, fix_restart_unit_scaling use MOM_variables, only : surface @@ -60,7 +60,7 @@ module MOM_ice_shelf #endif public shelf_calc_flux, add_shelf_flux, initialize_ice_shelf, ice_shelf_end -public ice_shelf_save_restart, solo_time_step, add_shelf_forces +public ice_shelf_save_restart, solo_step_ice_shelf, add_shelf_forces ! A note on unit descriptions in comments: MOM6 uses units that can be rescaled for dimensional ! consistency testing. These are noted in comments with units like Z, H, L, and T, along with @@ -1786,72 +1786,66 @@ subroutine ice_shelf_end(CS) end subroutine ice_shelf_end !> This routine is for stepping a stand-alone ice shelf model without an ocean. -subroutine solo_time_step(CS, time_interval, nsteps, Time, min_time_step_in) - type(ice_shelf_CS), pointer :: CS !< A pointer to the ice shelf control structure - real, intent(in) :: time_interval !< The time interval for this update [s]. +subroutine solo_step_ice_shelf(CS, time_interval, nsteps, Time, min_time_step_in) + type(ice_shelf_CS), pointer :: CS !< A pointer to the ice shelf control structure + type(time_type), intent(in) :: time_interval !< The time interval for this update [s]. integer, intent(inout) :: nsteps !< The running number of ice shelf steps. - type(time_type), intent(inout) :: Time !< The current model time - real, optional, intent(in) :: min_time_step_in !< The minimum permitted time step [s]. + type(time_type), intent(inout) :: Time !< The current model time + real, optional, intent(in) :: min_time_step_in !< The minimum permitted time step [T ~> s]. - type(ocean_grid_type), pointer :: G => NULL() + type(ocean_grid_type), pointer :: G => NULL() ! A pointer to the ocean's grid structure type(unit_scale_type), pointer :: US => NULL() ! Pointer to a structure containing ! various unit conversion factors 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 - real :: time_step_remain - real :: time_step_int, min_time_step + real :: remaining_time ! The remaining time in this call [T ~> s] + real :: time_step ! The internal time step during this call [T ~> s] + real :: min_time_step ! The minimal required timestep that would indicate a fatal problem [T ~> s] character(len=240) :: mesg logical :: update_ice_vel ! If true, it is time to update the ice shelf velocities. logical :: coupled_GL ! If true the grouding line position is determined based on ! coupled ice-ocean dynamics. + integer :: is, iec, js, jec, i, j G => CS%grid US => CS%US ISS => CS%ISS is = G%isc ; iec = G%iec ; js = G%jsc ; jec = G%jec - time_step = time_interval + remaining_time = US%s_to_T*time_type_to_real(time_interval) - 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 + min_time_step = 1000.0*US%s_to_T ! At 1 km resolution this would imply ice is moving at ~1 meter per second endif write (mesg,*) "TIME in ice shelf call, yrs: ", time_type_to_real(Time)/(365. * 86400.) - call MOM_mesg("solo_time_step: "//mesg) + call MOM_mesg("solo_step_ice_shelf: "//mesg, 5) - do while (time_step_remain > 0.0) + do while (remaining_time > 0.0) nsteps = nsteps+1 - ! If time_step is not too long, this is unnecessary. - time_step_int = min(US%T_to_s*ice_time_step_CFL(CS%dCS, ISS, G), time_step) + ! If time_interval is not too long, this is unnecessary. + time_step = min(ice_time_step_CFL(CS%dCS, ISS, G), remaining_time) - 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) + write (mesg,*) "Ice model timestep = ", US%T_to_s*time_step, " seconds" + if ((time_step < min_time_step) .and. (time_step < remaining_time)) then + call MOM_error(FATAL, "MOM_ice_shelf:solo_step_ice_shelf: abnormally small timestep "//mesg) else - call MOM_mesg("solo_time_step: "//mesg) + call MOM_mesg("solo_step_ice_shelf: "//mesg, 5) 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 + remaining_time = remaining_time - time_step ! 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)) + update_ice_vel = ((time_step > min_time_step) .or. (remaining_time > 0.0)) coupled_GL = .false. - call update_ice_shelf(CS%dCS, ISS, G, US, US%s_to_T*time_step_int, Time, must_update_vel=update_ice_vel) + call update_ice_shelf(CS%dCS, ISS, G, US, time_step, Time, must_update_vel=update_ice_vel) - call enable_averaging(time_step,Time,CS%diag) + call enable_averages(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) @@ -1859,7 +1853,7 @@ subroutine solo_time_step(CS, time_interval, nsteps, Time, min_time_step_in) enddo -end subroutine solo_time_step +end subroutine solo_step_ice_shelf !> \namespace mom_ice_shelf !! @@ -1877,7 +1871,7 @@ end subroutine solo_time_step !! 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). -!! solo_time_step - called only in ice-only mode. +!! solo_step_ice_shelf - 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 in fully dynamic mode. !! From e45326b263ffed2400bfcab648b2ec2fba3b5786 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 26 Mar 2020 09:03:23 -0400 Subject: [PATCH 125/316] (*)+Fix grid length use in MOM_ice_shelf_dynamics.F90 Corrected the grid face lengths used to calculate the mass and tracer fluxes. This will change answers on a non-Cartesian grid, and because of some bug corrections, it will change answers if the x- and y- grid spacings are not the same. Added comments with the correct units for several variables. Rearranged the order of indices in Phi for more efficient memory access. Applied the MOM6 convention to the case of indicies to indicate grid staggering. Some variable names were changed for brevity. All answers are bitwise identical in the MOM6-examples test cases, but there are substantial changes to the MOM_ice_shelf_dynamics.F90 code and it should be noted that there are no active tests of the ice shelf dynamics code. --- src/ice_shelf/MOM_ice_shelf_dynamics.F90 | 730 +++++++++++------------ 1 file changed, 361 insertions(+), 369 deletions(-) diff --git a/src/ice_shelf/MOM_ice_shelf_dynamics.F90 b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 index 908e79896a..0aae1d35f8 100644 --- a/src/ice_shelf/MOM_ice_shelf_dynamics.F90 +++ b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 @@ -72,7 +72,7 @@ module MOM_ice_shelf_dynamics real, pointer, dimension(:,:) :: t_shelf => NULL() !< Veritcally integrated temperature in the ice shelf/stream, !! on corner-points (B grid) [degC] real, pointer, dimension(:,:) :: tmask => NULL() !< A mask on tracer points that is 1 where there is ice. - real, pointer, dimension(:,:) :: ice_visc => NULL() !< Glen's law ice viscosity, perhaps in [m]. + real, pointer, dimension(:,:) :: ice_visc => NULL() !< Glen's law ice viscosity, often in [R L4 Z T-1 ~> kg m2 s-1]. real, pointer, dimension(:,:) :: thickness_bdry_val => NULL() !< The ice thickness at an inflowing boundary [Z ~> m]. real, pointer, dimension(:,:) :: u_bdry_val => NULL() !< The zonal ice velocity at inflowing boundaries !! [L yr-1 ~> m yr-1] @@ -81,8 +81,8 @@ module MOM_ice_shelf_dynamics real, pointer, dimension(:,:) :: h_bdry_val => NULL() !< The ice thickness at inflowing boundaries [m]. real, pointer, dimension(:,:) :: t_bdry_val => NULL() !< The ice temperature at inflowing boundaries [degC]. - real, pointer, dimension(:,:) :: basal_traction => NULL() !< nonlinear part of "linearized" basal stress. - !! [L-2 ? ~> m-2 ?] + real, pointer, dimension(:,:) :: basal_traction => NULL() !< The nonlinear part of "linearized" + !! basal stress [R Z T-1 ~> kg m-2 s-1]. !! The exact form depends on basal law exponent and/or whether flow is "hybridized" a la Goldberg 2011 real, pointer, dimension(:,:) :: OD_rt => NULL() !< A running total for calculating OD_av. @@ -255,9 +255,9 @@ subroutine register_ice_shelf_dyn_restarts(G, param_file, CS, restart_CS) call register_restart_field(CS%ground_frac, "ground_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)") + "Volume integrated Glens law ice viscosity", "kg m2 s-1") call register_restart_field(CS%basal_traction, "tau_b_beta", .true., restart_CS, & - "Coefficient of basal traction", "m (seems wrong)") + "Coefficient of basal traction", "kg m-2 s-1") endif end subroutine register_ice_shelf_dyn_restarts @@ -460,15 +460,18 @@ subroutine initialize_ice_shelf_dyn(param_file, Time, ISS, CS, G, US, diag, new_ ! 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 - !### What about v_shelf? 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) + 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) + CS%v_shelf(I-1,J-1) = CS%v_bdry_val(I-1,J-1) + CS%v_shelf(I-1,J) = CS%v_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) + 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) + CS%v_shelf(I-1,J-1) = CS%v_bdry_val(I-1,J-1) + CS%v_shelf(I,J-1) = CS%v_bdry_val(I,J-1) endif enddo ; enddo endif @@ -811,8 +814,6 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u_shlf, v_shlf, iters, time) ! quadrature points surrounding the cell verticies [m-1]. real, pointer, dimension(:,:,:,:,:,:) :: Phisub => NULL() ! Quadrature structure weights at subgridscale ! locations for finite element calculations [nondim] - real, dimension(8,4) :: Phi_temp ! The gradients of bilinear basis elements at Gaussian - ! quadrature points surrounding a cell vertex [L-1 ~> m-1]. character(2) :: iternum character(2) :: numproc @@ -867,11 +868,10 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u_shlf, v_shlf, iters, time) endif ! must prepare Phi - allocate(Phi(isd:ied,jsd:jed,1:8,1:4)) ; Phi(:,:,:,:) = 0.0 + allocate(Phi(1:8,1:4,isd:ied,jsd:jed)) ; Phi(:,:,:,:) = 0.0 do j=jsd,jed ; do i=isd,ied - call bilinear_shape_fn_grid(G, i, j, Phi_temp) - Phi(i,j,:,:) = Phi_temp + call bilinear_shape_fn_grid(G, i, j, Phi(:,:,i,j)) enddo ; enddo call calc_shelf_visc(CS, ISS, G, US, u_shlf, v_shlf) @@ -891,7 +891,7 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u_shlf, v_shlf, iters, time) Au(:,:) = 0.0 ; Av(:,:) = 0.0 call CG_action(Au, Av, u_shlf, v_shlf, Phi, Phisub, CS%umask, CS%vmask, ISS%hmask, H_node, & - CS%ice_visc, float_cond, G%bathyT, CS%basal_traction, G%areaT, & + CS%ice_visc, float_cond, G%bathyT, CS%basal_traction, & G, US, G%isc-1, G%iec+1, G%jsc-1, G%jec+1, rhoi_rhow) if (CS%nonlin_solve_err_mode == 1) then @@ -901,7 +901,7 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u_shlf, v_shlf, iters, time) err_tempu = ABS(Au(I,J) + u_bdry_cont(I,J) - taudx(I,J)) if (err_tempu >= err_init) err_init = err_tempu endif - if (CS%vmask(i,j) == 1) then + if (CS%vmask(I,J) == 1) then err_tempv = ABS(Av(I,J) + v_bdry_cont(I,J) - taudy(I,J)) if (err_tempv >= err_init) err_init = err_tempv endif @@ -946,7 +946,7 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u_shlf, v_shlf, iters, time) Au(:,:) = 0 ; Av(:,:) = 0 call CG_action(Au, Av, u_shlf, v_shlf, Phi, Phisub, CS%umask, CS%vmask, ISS%hmask, H_node, & - CS%ice_visc, float_cond, G%bathyT, CS%basal_traction, G%areaT, & + CS%ice_visc, float_cond, G%bathyT, CS%basal_traction, & G, US, G%isc-1, G%iec+1, G%jsc-1, G%jec+1, rhoi_rhow) err_max = 0 @@ -970,7 +970,7 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u_shlf, v_shlf, iters, time) max_vel = 0 ; tempu = 0 ; tempv = 0 do J=G%jscB,G%jecB ; do I=G%iscB,G%iecB - if (CS%umask(i,j) == 1) then + if (CS%umask(I,J) == 1) then err_tempu = ABS(u_last(I,J)-u_shlf(I,J)) if (err_tempu >= err_max) err_max = err_tempu tempu = u_shlf(I,J) @@ -1037,7 +1037,7 @@ subroutine ice_shelf_solve_inner(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, H !! 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), & + real, dimension(8,4,SZDI_(G),SZDJ_(G)), & intent(in) :: Phi !< The gradients of bilinear basis elements at Gaussian !! quadrature points surrounding the cell verticies [L-1 ~> m-1]. real, dimension(:,:,:,:,:,:), & @@ -1114,7 +1114,7 @@ subroutine ice_shelf_solve_inner(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, H call CG_action(Au, Av, u_shlf, v_shlf, Phi, Phisub, CS%umask, CS%vmask, hmask, & H_node, CS%ice_visc, float_cond, G%bathyT, CS%basal_traction, & - G%areaT, G, US, isc-1, iec+1, jsc-1, jec+1, rhoi_rhow) + G, US, isc-1, iec+1, jsc-1, jec+1, rhoi_rhow) call pass_vector(Au, Av, G%domain, TO_ALL, BGRID_NE) @@ -1126,8 +1126,8 @@ subroutine ice_shelf_solve_inner(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, H sum_vec(:,:) = 0.0 do j=jscq,jecq ; do i=iscq,iecq - if (CS%umask(i,j) == 1) sum_vec(i,j) = resid2_scale*Ru(i,j)**2 - if (CS%vmask(i,j) == 1) sum_vec(i,j) = sum_vec(i,j) + resid2_scale*Rv(i,j)**2 + if (CS%umask(I,J) == 1) sum_vec(I,J) = resid2_scale*Ru(I,J)**2 + if (CS%vmask(I,J) == 1) sum_vec(I,J) = sum_vec(I,J) + resid2_scale*Rv(I,J)**2 enddo ; enddo dot_p1 = reproducing_sum( sum_vec, Js_sum, Ie_sum, Js_sum, Je_sum ) @@ -1136,8 +1136,8 @@ subroutine ice_shelf_solve_inner(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, H 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) + 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 @@ -1168,7 +1168,7 @@ subroutine ice_shelf_solve_inner(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, H call CG_action(Au, Av, Du, Dv, Phi, Phisub, CS%umask, CS%vmask, hmask, & H_node, CS%ice_visc, float_cond, G%bathyT, CS%basal_traction, & - G%areaT, G, US, is, ie, js, je, rhoi_rhow) + G, US, is, ie, js, je, rhoi_rhow) ! Au, Av valid region moves in by 1 @@ -1176,13 +1176,13 @@ subroutine ice_shelf_solve_inner(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, H sum_vec(:,:) = 0.0 ; sum_vec_2(:,:) = 0.0 do j=jscq,jecq ; do i=iscq,iecq - if (CS%umask(i,j) == 1) then - sum_vec(i,j) = resid_scale * Zu(i,j) * Ru(i,j) - sum_vec_2(i,j) = resid_scale * Du(i,j) * Au(i,j) + if (CS%umask(I,J) == 1) then + sum_vec(I,J) = resid_scale * Zu(I,J) * Ru(I,J) + sum_vec_2(I,J) = resid_scale * Du(I,J) * Au(I,J) endif - if (CS%vmask(i,j) == 1) then - sum_vec(i,j) = sum_vec(i,j) + resid_scale * Zv(i,j) * Rv(i,j) - sum_vec_2(i,j) = sum_vec_2(i,j) + resid_scale * Dv(i,j) * Av(i,j) + if (CS%vmask(I,J) == 1) then + sum_vec(I,J) = sum_vec(I,J) + resid_scale * Zv(I,J) * Rv(I,J) + sum_vec_2(I,J) = sum_vec_2(I,J) + resid_scale * Dv(I,J) * Av(I,J) endif enddo ; enddo @@ -1191,16 +1191,16 @@ subroutine ice_shelf_solve_inner(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, H do j=jsd,jed ; do i=isd,ied - if (CS%umask(i,j) == 1) u_shlf(I,J) = u_shlf(I,J) + alpha_k * Du(i,j) - if (CS%vmask(i,j) == 1) v_shlf(I,J) = v_shlf(I,J) + alpha_k * Dv(i,j) + if (CS%umask(I,J) == 1) u_shlf(I,J) = u_shlf(I,J) + alpha_k * Du(I,J) + if (CS%vmask(I,J) == 1) v_shlf(I,J) = v_shlf(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) + 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) + if (CS%vmask(I,J) == 1) then + Rv_old(I,J) = Rv(I,J) ; Zv_old(I,J) = Zv(I,J) endif enddo ; enddo @@ -1209,18 +1209,18 @@ subroutine ice_shelf_solve_inner(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, H 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) + 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) + 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) + if (CS%vmask(I,J) == 1) then + Zv(I,J) = Rv(I,J) / DIAGv(I,J) endif enddo enddo @@ -1231,13 +1231,13 @@ subroutine ice_shelf_solve_inner(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, H sum_vec(:,:) = 0.0 ; sum_vec_2(:,:) = 0.0 do j=jscq,jecq ; do i=iscq,iecq - if (CS%umask(i,j) == 1) then - sum_vec(i,j) = resid_scale * Zu(i,j) * Ru(i,j) - sum_vec_2(i,j) = resid_scale * Zu_old(i,j) * Ru_old(i,j) + if (CS%umask(I,J) == 1) then + sum_vec(I,J) = resid_scale * Zu(I,J) * Ru(I,J) + sum_vec_2(I,J) = resid_scale * Zu_old(I,J) * Ru_old(I,J) endif - if (CS%vmask(i,j) == 1) then - sum_vec(i,j) = sum_vec(i,j) + resid_scale * Zv(i,j) * Rv(i,j) - sum_vec_2(i,j) = sum_vec_2(i,j) + resid_scale * Zv_old(i,j) * Rv_old(i,j) + if (CS%vmask(I,J) == 1) then + sum_vec(I,J) = sum_vec(I,J) + resid_scale * Zv(I,J) * Rv(I,J) + sum_vec_2(I,J) = sum_vec_2(I,J) + resid_scale * Zv_old(I,J) * Rv_old(I,J) endif enddo ; enddo @@ -1249,8 +1249,8 @@ subroutine ice_shelf_solve_inner(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, H 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) + 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 @@ -1258,8 +1258,8 @@ subroutine ice_shelf_solve_inner(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, H sum_vec(:,:) = 0.0 do j=jscq,jecq ; do i=iscq,iecq - if (CS%umask(i,j) == 1) sum_vec(i,j) = resid2_scale*Ru(i,j)**2 - if (CS%vmask(i,j) == 1) sum_vec(i,j) = sum_vec(i,j) + resid2_scale*Rv(i,j)**2 + if (CS%umask(I,J) == 1) sum_vec(I,J) = resid2_scale*Ru(I,J)**2 + if (CS%vmask(I,J) == 1) sum_vec(I,J) = sum_vec(I,J) + resid2_scale*Rv(I,J)**2 enddo ; enddo dot_p1 = reproducing_sum( sum_vec, Is_sum, Ie_sum, Js_sum, Je_sum ) @@ -1285,15 +1285,15 @@ subroutine ice_shelf_solve_inner(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, H do j=jsdq,jedq do i=isdq,iedq - if (CS%umask(i,j) == 3) then - u_shlf(I,J) = CS%u_bdry_val(i,j) - elseif (CS%umask(i,j) == 0) then + if (CS%umask(I,J) == 3) then + u_shlf(I,J) = CS%u_bdry_val(I,J) + elseif (CS%umask(I,J) == 0) then u_shlf(I,J) = 0 endif - if (CS%vmask(i,j) == 3) then - v_shlf(I,J) = CS%v_bdry_val(i,j) - elseif (CS%vmask(i,j) == 0) then + if (CS%vmask(I,J) == 3) then + v_shlf(I,J) = CS%v_bdry_val(I,J) + elseif (CS%vmask(I,J) == 0) then v_shlf(I,J) = 0 endif enddo @@ -1346,7 +1346,7 @@ subroutine ice_shelf_advect_thickness_x(CS, G, time_step, hmask, h0, h_after_ufl logical :: at_east_bdry, at_west_bdry, one_off_west_bdry, one_off_east_bdry real, dimension(-2:2) :: stencil ! Thicknesses [Z ~> m]. real :: u_face ! Zonal velocity at a face, positive if out {L Z-1 ~> m s-1] - real :: flux_diff_cell + real :: flux_diff real :: slope_lim ! The value of the slope limiter, in the range of 0 to 2 [nondim] character (len=1) :: debug_str @@ -1383,18 +1383,18 @@ subroutine ice_shelf_advect_thickness_x(CS, G, time_step, hmask, h0, h_after_ufl stencil(:) = h0(i-2:i+2,j) ! fine as long has nx_halo >= 2 - flux_diff_cell = 0 + flux_diff = 0 ! 1ST DO LEFT FACE - if (CS%u_face_mask(i-1,j) == 4.) then + if (CS%u_face_mask(I-1,j) == 4.) then - flux_diff_cell = flux_diff_cell + G%dyT(i,j) * time_step * CS%u_flux_bdry_val(i-1,j) / G%areaT(i,j) + flux_diff = flux_diff + G%dyCu(I-1,j) * time_step * CS%u_flux_bdry_val(I-1,j) / G%areaT(i,j) 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)) + 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 @@ -1403,32 +1403,29 @@ subroutine ice_shelf_advect_thickness_x(CS, G, time_step, hmask, h0, h_after_ufl 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) * G%dyT(i,j) * time_step * stencil(-1) / G%areaT(i,j) + flux_diff = flux_diff + ABS(u_face) * G%dyCu(I-1,j) * time_step * stencil(-1) / G%areaT(i,j) elseif (hmask(i-1,j) * hmask(i-2,j) == 1) then ! h(i-2) and h(i-1) are valid slope_lim = slope_limiter(stencil(-1)-stencil(-2), stencil(0)-stencil(-1)) - flux_diff_cell = flux_diff_cell + ABS(u_face) * G%dyT(i,j)* time_step / G%areaT(i,j) * & + flux_diff = flux_diff + ABS(u_face) * G%dyCu(I-1,j)* time_step / G%areaT(i,j) * & (stencil(-1) - slope_lim * (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) * (G%dyT(i,j) * time_step / G%areaT(i,j)) * stencil(-1) + else ! h(i-1) is valid (o.w. flux would most likely be out of cell) but h(i-2) is not + flux_diff = flux_diff + ABS(u_face) * (G%dyCu(I-1,j) * time_step / G%areaT(i,j)) * 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 slope_lim = slope_limiter(stencil(0)-stencil(1), stencil(-1)-stencil(0)) - flux_diff_cell = flux_diff_cell - ABS(u_face) * G%dyT(i,j) * time_step / G%areaT(i,j) * & + flux_diff = flux_diff - ABS(u_face) * G%dyCu(I-1,j) * time_step / G%areaT(i,j) * & (stencil(0) - slope_lim * (stencil(0)-stencil(-1))/2) else - flux_diff_cell = flux_diff_cell - ABS(u_face) * (G%dyT(i,j) * time_step / G%areaT(i,j)) * stencil(0) + flux_diff = flux_diff - ABS(u_face) * (G%dyCu(I-1,j) * time_step / G%areaT(i,j)) * stencil(0) if ((hmask(i-1,j) == 0) .OR. (hmask(i-1,j) == 2)) then - flux_enter(i-1,j,2) = ABS(u_face) * G%dyT(i,j) * time_step * stencil(0) + flux_enter(i-1,j,2) = ABS(u_face) * G%dyCu(I-1,j) * time_step * stencil(0) endif endif endif @@ -1438,32 +1435,32 @@ subroutine ice_shelf_advect_thickness_x(CS, G, time_step, hmask, h0, h_after_ufl ! get u-velocity at center of right face - if (CS%u_face_mask(i+1,j) == 4.) then + if (CS%u_face_mask(I+1,j) == 4.) then - flux_diff_cell = flux_diff_cell + G%dyT(i,j) * time_step * CS%u_flux_bdry_val(i+1,j) / G%areaT(i,j) + flux_diff = flux_diff + G%dyCu(I,j) * time_step * CS%u_flux_bdry_val(I+1,j) / G%areaT(i,j) else - u_face = 0.5 * (CS%u_shelf(i,j-1) + CS%u_shelf(i,j)) + 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) * G%dyT(i,j) * time_step * stencil(1) / G%areaT(i,j) + flux_diff = flux_diff + ABS(u_face) * G%dyCu(I,j) * time_step * stencil(1) / G%areaT(i,j) elseif (hmask(i+1,j) * hmask(i+2,j) == 1) then ! h(i+2) and h(i+1) are valid slope_lim = slope_limiter(stencil(1)-stencil(2), stencil(0)-stencil(1)) - flux_diff_cell = flux_diff_cell + ABS(u_face) * G%dyT(i,j) * time_step / G%areaT(i,j) * & + flux_diff = flux_diff + ABS(u_face) * G%dyCu(I,j) * time_step / G%areaT(i,j) * & (stencil(1) - slope_lim * (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) * (G%dyT(i,j) * time_step / G%areaT(i,j)) * stencil(1) + flux_diff = flux_diff + ABS(u_face) * (G%dyCu(I,j) * time_step / G%areaT(i,j)) * stencil(1) endif @@ -1472,41 +1469,41 @@ subroutine ice_shelf_advect_thickness_x(CS, G, time_step, hmask, h0, h_after_ufl if (hmask(i-1,j) * hmask(i+1,j) == 1) then ! h(i-1) and h(i+1) are both valid slope_lim = slope_limiter(stencil(0)-stencil(-1), stencil(1)-stencil(0)) - flux_diff_cell = flux_diff_cell - ABS(u_face) * G%dyT(i,j) * time_step / G%areaT(i,j) * & + flux_diff = flux_diff - ABS(u_face) * G%dyCu(I,j) * time_step / G%areaT(i,j) * & (stencil(0) - slope_lim * (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) * (G%dyT(i,j) * time_step / G%areaT(i,j)) * stencil(0) + flux_diff = flux_diff - ABS(u_face) * (G%dyCu(I,j) * time_step / G%areaT(i,j)) * stencil(0) if ((hmask(i+1,j) == 0) .OR. (hmask(i+1,j) == 2)) then - flux_enter(i+1,j,1) = ABS(u_face) * G%dyT(i,j) * time_step * stencil(0) + flux_enter(i+1,j,1) = ABS(u_face) * G%dyCu(I,j) * time_step * stencil(0) endif endif endif - h_after_uflux(i,j) = h_after_uflux(i,j) + flux_diff_cell + h_after_uflux(i,j) = h_after_uflux(i,j) + flux_diff 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) + 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%dyCu(I-1,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%dyCu(I-1,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) + u_face = 0.5 * (CS%u_shelf(I,J-1) + CS%u_shelf(I,J)) + flux_enter(i,j,2) = ABS(u_face) * G%dyCu(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%dyCu(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 @@ -1576,7 +1573,7 @@ subroutine ice_shelf_advect_thickness_y(CS, G, time_step, hmask, h_after_uflux, logical :: at_north_bdry, at_south_bdry, one_off_west_bdry, one_off_east_bdry real, dimension(-2:2) :: stencil ! Thicknesses [Z ~> m]. real :: v_face ! Pseudo-meridional velocity at a cell face, positive if out {L T-1 ~> m s-1] - real :: flux_diff_cell + real :: flux_diff real :: slope_lim ! The value of the slope limiter, in the range of 0 to 2 [nondim] character(len=1) :: debug_str @@ -1610,18 +1607,18 @@ subroutine ice_shelf_advect_thickness_y(CS, G, time_step, hmask, h_after_uflux, 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 + flux_diff = 0 ! 1ST DO south FACE - if (CS%v_face_mask(i,j-1) == 4.) then + if (CS%v_face_mask(i,J-1) == 4.) then - flux_diff_cell = flux_diff_cell + G%dxT(i,j) * time_step * CS%v_flux_bdry_val(i,j-1) / G%areaT(i,j) + flux_diff = flux_diff + G%dxCv(i,J-1) * time_step * CS%v_flux_bdry_val(i,J-1) / G%areaT(i,j) 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)) + 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 @@ -1629,32 +1626,31 @@ subroutine ice_shelf_advect_thickness_y(CS, G, time_step, hmask, h_after_uflux, 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) * G%dxT(i,j) * time_step * stencil(-1) / G%areaT(i,j) + flux_diff = flux_diff + ABS(v_face) * G%dxCv(i,J-1) * time_step * stencil(-1) / G%areaT(i,j) elseif (hmask(i,j-1) * hmask(i,j-2) == 1) then ! h(j-2) and h(j-1) are valid slope_lim = slope_limiter(stencil(-1)-stencil(-2), stencil(0)-stencil(-1)) - flux_diff_cell = flux_diff_cell + ABS(v_face) * G%dxT(i,j) * time_step / G%areaT(i,j) * & + flux_diff = flux_diff + ABS(v_face) * G%dxCv(i,J-1) * time_step / G%areaT(i,j) * & (stencil(-1) - slope_lim * (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) * (G%dxT(i,j) * time_step / G%areaT(i,j)) * stencil(-1) + flux_diff = flux_diff + ABS(v_face) * (G%dxCv(i,J-1) * time_step / G%areaT(i,j)) * 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 slope_lim = slope_limiter(stencil(0)-stencil(1), stencil(-1)-stencil(0)) - flux_diff_cell = flux_diff_cell - ABS(v_face) * G%dxT(i,j) * time_step / G%areaT(i,j) * & + flux_diff = flux_diff - ABS(v_face) * G%dxCv(i,J-1) * time_step / G%areaT(i,j) * & (stencil(0) - slope_lim * (stencil(0)-stencil(-1))/2) else - flux_diff_cell = flux_diff_cell - ABS(v_face) * (G%dxT(i,j) * time_step / G%areaT(i,j)) * stencil(0) + flux_diff = flux_diff - ABS(v_face) * (G%dxCv(i,J-1) * time_step / G%areaT(i,j)) * stencil(0) - !### The G%dyT in the next line needs to become G%dxCu(i,J-1) if ((hmask(i,j-1) == 0) .OR. (hmask(i,j-1) == 2)) then - flux_enter(i,j-1,4) = ABS(v_face) * G%dyT(i,j) * time_step * stencil(0) + flux_enter(i,j-1,4) = ABS(v_face) * G%dxCv(i,J-1) * time_step * stencil(0) endif endif @@ -1665,42 +1661,42 @@ subroutine ice_shelf_advect_thickness_y(CS, G, time_step, hmask, h_after_uflux, ! NEXT DO north FACE - if (CS%v_face_mask(i,j+1) == 4.) then + if (CS%v_face_mask(i,J+1) == 4.) then - flux_diff_cell = flux_diff_cell + G%dxT(i,j) * time_step * CS%v_flux_bdry_val(i,j+1) / G%areaT(i,j) + flux_diff = flux_diff + G%dxCv(i,J) * time_step * CS%v_flux_bdry_val(i,J+1) / G%areaT(i,j) else - ! get u-velocity at center of right face - v_face = 0.5 * (CS%v_shelf(i-1,j) + CS%v_shelf(i,j)) + ! get v-velocity at center of north 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) * G%dxT(i,j) * time_step * stencil(1) / G%areaT(i,j) + flux_diff = flux_diff + ABS(v_face) * G%dxCv(i,J) * time_step * stencil(1) / G%areaT(i,j) elseif (hmask(i,j+1) * hmask(i,j+2) == 1) then ! h(j+2) and h(j+1) are valid slope_lim = slope_limiter(stencil(1)-stencil(2), stencil(0)-stencil(1)) - flux_diff_cell = flux_diff_cell + ABS(v_face) * G%dxT(i,j) * time_step / G%areaT(i,j) * & + flux_diff = flux_diff + ABS(v_face) * G%dxCv(i,J) * time_step / G%areaT(i,j) * & (stencil(1) - slope_lim * (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) * G%dxT(i,j) * time_step / G%areaT(i,j) * stencil(1) + flux_diff = flux_diff + ABS(v_face) * G%dxCv(i,J) * time_step / G%areaT(i,j) * 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 slope_lim = slope_limiter(stencil(0)-stencil(-1), stencil(1)-stencil(0)) - flux_diff_cell = flux_diff_cell - ABS(v_face) * G%dxT(i,j) * time_step / G%areaT(i,j) * & + flux_diff = flux_diff - ABS(v_face) * G%dxCv(i,J) * time_step / G%areaT(i,j) * & (stencil(0) - slope_lim * (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) * G%dxT(i,j) * time_step / G%areaT(i,j) * stencil(0) + flux_diff = flux_diff - ABS(v_face) * G%dxCv(i,J) * time_step / G%areaT(i,j) * stencil(0) if ((hmask(i,j+1) == 0) .OR. (hmask(i,j+1) == 2)) then - flux_enter(i,j+1,3) = ABS(v_face) * G%dxT(i,j) * time_step * stencil(0) + flux_enter(i,j+1,3) = ABS(v_face) * G%dxCv(i,J) * time_step * stencil(0) endif endif @@ -1708,22 +1704,22 @@ subroutine ice_shelf_advect_thickness_y(CS, G, time_step, hmask, h_after_uflux, endif - h_after_vflux(i,j) = h_after_vflux(i,j) + flux_diff_cell + h_after_vflux(i,j) = h_after_vflux(i,j) + flux_diff 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) + 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%dxCv(i,J-1) * 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%dxCv(i,J-1) * 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) + v_face = 0.5 * (CS%u_shelf(I-1,J) + CS%u_shelf(I,J)) + flux_enter(i,j,4) = ABS(v_face) * G%dxCv(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%dxCv(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 @@ -1875,13 +1871,13 @@ subroutine shelf_advance_front(CS, ISS, G, flux_enter) n_flux = 0 ; new_partial(:) = 0 do k=1,2 - if (CS%u_face_mask(i-2+k,j) == 2) then + 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 - if (CS%v_face_mask(i,j-2+k) == 2) then + 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 @@ -2129,7 +2125,7 @@ subroutine calc_shelf_driving_stress(CS, ISS, G, US, taudx, taudy, OD) 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 + 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 @@ -2143,19 +2139,19 @@ subroutine calc_shelf_driving_stress(CS, ISS, G, US, taudx, taudy, OD) taudx(I-1,J) = taudx(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 + 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 taudx(I,J-1) = taudx(I,J-1) + .5 * dyh * neumann_val taudx(I,J) = taudx(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 + 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 taudy(I-1,J-1) = taudy(I-1,J-1) - .5 * dxh * neumann_val taudy(I,J-1) = taudy(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 + 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 taudy(I-1,J) = taudy(I-1,J) + .5 * dxh * neumann_val taudy(I,J) = taudy(I,J) + .5 * dxh * neumann_val @@ -2205,25 +2201,28 @@ subroutine init_boundary_values(CS, G, time, hmask, input_flux, input_thick, new 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) * & + 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) * & + 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 - !### What about v_shelf? 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) + 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) + CS%v_shelf(I-1,J-1) = CS%v_bdry_val(I-1,J-1) + CS%v_shelf(I-1,J) = CS%v_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) + 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) + CS%v_shelf(I-1,J-1) = CS%v_bdry_val(I-1,J-1) + CS%v_shelf(I,J-1) = CS%v_bdry_val(I,J-1) endif endif endif @@ -2234,7 +2233,7 @@ end subroutine init_boundary_values subroutine CG_action(uret, vret, u_shlf, v_shlf, Phi, Phisub, umask, vmask, hmask, H_node, & - ice_visc, float_cond, bathyT, basal_trac, dxdyh, G, US, is, ie, js, je, dens_ratio) + ice_visc, float_cond, bathyT, basal_trac, G, US, 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), & @@ -2265,8 +2264,8 @@ subroutine CG_action(uret, vret, u_shlf, v_shlf, Phi, Phisub, umask, vmask, hmas !! partly or fully covered by an ice-shelf real, dimension(SZDIB_(G),SZDJB_(G)), & intent(in) :: ice_visc !< A field related to the ice viscosity from Glen's - !! flow law. The exact form and units depend on the - !! basal law exponent. [?] + !! flow law [R L4 Z T-1 ~> kg m2 s-1]. The exact form + !! and units depend on the basal law exponent. real, dimension(SZDI_(G),SZDJ_(G)), & intent(in) :: float_cond !< An array indicating where the ice !! shelf is floating: 0 if floating, 1 if not. @@ -2274,11 +2273,8 @@ subroutine CG_action(uret, vret, u_shlf, v_shlf, Phi, Phisub, umask, vmask, hmas intent(in) :: bathyT !< The depth of ocean bathymetry at tracer points [Z ~> m]. real, dimension(SZDIB_(G),SZDJB_(G)), & intent(in) :: basal_trac !< A field related to the nonlinear part of the - !! "linearized" basal stress. The exact form and - !! units depend on the basal law exponent. [L-2 ? ~> m-2 ?] + !! "linearized" basal stress [R Z T-1 ~> kg m-2 s-1]. ! and/or whether flow is "hybridized" - real, dimension(SZDI_(G),SZDJ_(G)), & - intent(in) :: dxdyh !< The tracer cell area [L2 ~> m2] real, intent(in) :: dens_ratio !< The density of ice divided by the density !! of seawater, nondimensional type(unit_scale_type), intent(in) :: US !< A structure containing unit conversion factors @@ -2296,21 +2292,21 @@ subroutine CG_action(uret, vret, u_shlf, v_shlf, Phi, Phisub, umask, vmask, hmas ! 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 +! Phi(k,q,i,j) - 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(2*k-1,q,i,j) gives d(Phi_k)/dx at quadrature point q +! Phi(2*k,q,i,j) 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, uy, vx, vy ! Components of velocity shears or divergence [T-1 ~> s-1] real :: uq, vq ! Interpolated velocities [L T-1 ~> m s-1] integer :: iq, jq, iphi, jphi, i, j, ilq, jlq real, dimension(2) :: xquad - real, dimension(2,2) :: Ucell,Vcell,Hcell,Usubcontr,Vsubcontr ! ,Ucontr + real, dimension(2,2) :: Ucell, Vcell, Hcell, Usubcontr, Vsubcontr xquad(1) = .5 * (1-sqrt(1./3)) ; xquad(2) = .5 * (1+sqrt(1./3)) @@ -2318,60 +2314,60 @@ subroutine CG_action(uret, vret, u_shlf, v_shlf, Phi, Phisub, umask, vmask, hmas do iq=1,2 ; do jq=1,2 - uq = u_shlf(i-1,j-1) * xquad(3-iq) * xquad(3-jq) + & - u_shlf(i,j-1) * xquad(iq) * xquad(3-jq) + & - u_shlf(i-1,j) * xquad(3-iq) * xquad(jq) + & - u_shlf(i,j) * xquad(iq) * xquad(jq) + uq = u_shlf(I-1,J-1) * xquad(3-iq) * xquad(3-jq) + & + u_shlf(I,J-1) * xquad(iq) * xquad(3-jq) + & + u_shlf(I-1,J) * xquad(3-iq) * xquad(jq) + & + u_shlf(I,J) * xquad(iq) * xquad(jq) - vq = v_shlf(i-1,j-1) * xquad(3-iq) * xquad(3-jq) + & - v_shlf(i,j-1) * xquad(iq) * xquad(3-jq) + & - v_shlf(i-1,j) * xquad(3-iq) * xquad(jq) + & - v_shlf(i,j) * xquad(iq) * xquad(jq) + vq = v_shlf(I-1,J-1) * xquad(3-iq) * xquad(3-jq) + & + v_shlf(I,J-1) * xquad(iq) * xquad(3-jq) + & + v_shlf(I-1,J) * xquad(3-iq) * xquad(jq) + & + v_shlf(I,J) * xquad(iq) * xquad(jq) - ux = u_shlf(i-1,j-1) * Phi(i,j,1,2*(jq-1)+iq) + & - u_shlf(i,j-1) * Phi(i,j,3,2*(jq-1)+iq) + & - u_shlf(i-1,j) * Phi(i,j,5,2*(jq-1)+iq) + & - u_shlf(i,j) * Phi(i,j,7,2*(jq-1)+iq) + ux = u_shlf(I-1,J-1) * Phi(1,2*(jq-1)+iq,i,j) + & + u_shlf(I,J-1) * Phi(3,2*(jq-1)+iq,i,j) + & + u_shlf(I-1,J) * Phi(5,2*(jq-1)+iq,i,j) + & + u_shlf(I,J) * Phi(7,2*(jq-1)+iq,i,j) - vx = v_shlf(i-1,j-1) * Phi(i,j,1,2*(jq-1)+iq) + & - v_shlf(i,j-1) * Phi(i,j,3,2*(jq-1)+iq) + & - v_shlf(i-1,j) * Phi(i,j,5,2*(jq-1)+iq) + & - v_shlf(i,j) * Phi(i,j,7,2*(jq-1)+iq) + vx = v_shlf(I-1,J-1) * Phi(1,2*(jq-1)+iq,i,j) + & + v_shlf(I,J-1) * Phi(3,2*(jq-1)+iq,i,j) + & + v_shlf(I-1,J) * Phi(5,2*(jq-1)+iq,i,j) + & + v_shlf(I,J) * Phi(7,2*(jq-1)+iq,i,j) - uy = u_shlf(i-1,j-1) * Phi(i,j,2,2*(jq-1)+iq) + & - u_shlf(i,j-1) * Phi(i,j,4,2*(jq-1)+iq) + & - u_shlf(i-1,j) * Phi(i,j,6,2*(jq-1)+iq) + & - u_shlf(i,j) * Phi(i,j,8,2*(jq-1)+iq) + uy = u_shlf(I-1,J-1) * Phi(2,2*(jq-1)+iq,i,j) + & + u_shlf(I,J-1) * Phi(4,2*(jq-1)+iq,i,j) + & + u_shlf(I-1,J) * Phi(6,2*(jq-1)+iq,i,j) + & + u_shlf(I,J) * Phi(8,2*(jq-1)+iq,i,j) - vy = v_shlf(i-1,j-1) * Phi(i,j,2,2*(jq-1)+iq) + & - v_shlf(i,j-1) * Phi(i,j,4,2*(jq-1)+iq) + & - v_shlf(i-1,j) * Phi(i,j,6,2*(jq-1)+iq) + & - v_shlf(i,j) * Phi(i,j,8,2*(jq-1)+iq) + vy = v_shlf(I-1,j-1) * Phi(2,2*(jq-1)+iq,i,j) + & + v_shlf(I,J-1) * Phi(4,2*(jq-1)+iq,i,j) + & + v_shlf(I-1,J) * Phi(6,2*(jq-1)+iq,i,j) + & + v_shlf(I,J) * Phi(8,2*(jq-1)+iq,i,j) 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) + 0.25 * dxdyh(i,j) * ice_visc(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)) + if (umask(I-2+iphi,J-2+jphi) == 1) then + uret(I-2+iphi,J-2+jphi) = uret(I-2+iphi,J-2+jphi) + 0.25 * ice_visc(i,j) * & + ((4*ux+2*vy) * Phi(2*(2*(jphi-1)+iphi)-1,2*(jq-1)+iq,i,j) + & + (uy+vx) * Phi(2*(2*(jphi-1)+iphi),2*(jq-1)+iq,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) + 0.25 * dxdyh(i,j) * ice_visc(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)) + if (vmask(I-2+iphi,J-2+jphi) == 1) then + vret(I-2+iphi,J-2+jphi) = vret(I-2+iphi,J-2+jphi) + 0.25 * ice_visc(i,j) * & + ((uy+vx) * Phi(2*(2*(jphi-1)+iphi)-1,2*(jq-1)+iq,i,j) + & + (4*vy+2*ux) * Phi(2*(2*(jphi-1)+iphi),2*(jq-1)+iq,i,j)) endif if (float_cond(i,j) == 0) then ilq = 1 ; if (iq == iphi) ilq = 2 jlq = 1 ; if (jq == jphi) jlq = 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) + & - 0.25 * basal_trac(i,j) * dxdyh(i,j) * uq * xquad(ilq) * xquad(jlq) + if (umask(I-2+iphi,J-2+jphi) == 1) then + uret(I-2+iphi,J-2+jphi) = uret(I-2+iphi,J-2+jphi) + & + 0.25 * basal_trac(i,j) * G%areaT(i,j) * 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) + & - 0.25 * basal_trac(i,j) * dxdyh(i,j) * vq * xquad(ilq) * xquad(jlq) + if (vmask(I-2+iphi,J-2+jphi) == 1) then + vret(I-2+iphi,J-2+jphi) = vret(I-2+iphi,J-2+jphi) + & + 0.25 * basal_trac(i,j) * G%areaT(i,j) * vq * xquad(ilq) * xquad(jlq) endif endif @@ -2380,15 +2376,15 @@ subroutine CG_action(uret, vret, u_shlf, v_shlf, Phi, Phisub, umask, vmask, hmas if (float_cond(i,j) == 1) then Usubcontr = 0.0 ; Vsubcontr = 0.0 - Ucell(:,:) = u_shlf(i-1:i,j-1:j) ; Vcell(:,:) = v_shlf(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(i,j), bathyT(i,j), & + Ucell(:,:) = u_shlf(I-1:I,J-1:J) ; Vcell(:,:) = v_shlf(I-1:I,J-1:J) ; Hcell(:,:) = H_node(i-1:i,j-1:j) + call CG_action_subgrid_basal(Phisub, Hcell, Ucell, Vcell, G%areaT(i,j), bathyT(i,j), & 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) * basal_trac(i,j) + 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) * basal_trac(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) * basal_trac(i,j) + 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) * basal_trac(i,j) endif enddo ; enddo endif @@ -2453,12 +2449,11 @@ subroutine matrix_diagonal(CS, G, US, float_cond, H_node, ice_visc, basal_trac, !! (corner) points [Z ~> m]. real, dimension(SZDIB_(G),SZDJB_(G)), & intent(in) :: ice_visc !< A field related to the ice viscosity from Glen's - !! flow law. The exact form and units depend on the - !! basal law exponent. + !! flow law [R L4 Z T-1 ~> kg m2 s-1]. The exact form + !! and units depend on the basal law exponent. real, dimension(SZDIB_(G),SZDJB_(G)), & intent(in) :: basal_trac !< A field related to the nonlinear part of the - !! "linearized" basal stress. The exact form and - !! units depend on the basal law exponent [L-2 ? ~> m-2 ?] + !! "linearized" basal stress [R Z T-1 ~> kg m-2 s-1]. real, dimension(SZDI_(G),SZDJ_(G)), & intent(in) :: hmask !< A mask indicating which tracer points are !! partly or fully covered by an ice-shelf @@ -2499,39 +2494,38 @@ subroutine matrix_diagonal(CS, G, US, float_cond, H_node, ice_visc, basal_trac, ilq = 1 ; if (iq == iphi) ilq = 2 jlq = 1 ; if (jq == jphi) jlq = 2 - if (CS%umask(i-2+iphi,j-2+jphi) == 1) then + 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) + & - 0.25 * G%areaT(i,j) * ice_visc(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)) + u_diagonal(I-2+iphi,J-2+jphi) = u_diagonal(I-2+iphi,J-2+jphi) + & + 0.25 * ice_visc(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)) if (float_cond(i,j) == 0) then uq = xquad(ilq) * xquad(jlq) - !### uq seems to be duplicated here. Why not uq**2? - u_diagonal(i-2+iphi,j-2+jphi) = u_diagonal(i-2+iphi,j-2+jphi) + & + u_diagonal(I-2+iphi,J-2+jphi) = u_diagonal(I-2+iphi,J-2+jphi) + & 0.25 * basal_trac(i,j) * G%areaT(i,j) * uq * xquad(ilq) * xquad(jlq) endif endif - if (CS%vmask(i-2+iphi,j-2+jphi) == 1) then + 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) + & - 0.25 * G%areaT(i,j) * ice_visc(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)) + v_diagonal(I-2+iphi,J-2+jphi) = v_diagonal(I-2+iphi,J-2+jphi) + & + 0.25 * ice_visc(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 vq = xquad(ilq) * xquad(jlq) - v_diagonal(i-2+iphi,j-2+jphi) = v_diagonal(i-2+iphi,j-2+jphi) + & + v_diagonal(I-2+iphi,J-2+jphi) = v_diagonal(I-2+iphi,J-2+jphi) + & 0.25 * basal_trac(i,j) * G%areaT(i,j) * vq * xquad(ilq) * xquad(jlq) endif endif @@ -2542,9 +2536,9 @@ subroutine matrix_diagonal(CS, G, US, float_cond, H_node, ice_visc, basal_trac, Hcell(:,:) = H_node(i-1:i,j-1:j) call CG_diagonal_subgrid_basal(Phisub, Hcell, G%areaT(i,j), G%bathyT(i,j), 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) * basal_trac(i,j) - v_diagonal(i-2+iphi,j-2+jphi) = v_diagonal(i-2+iphi,j-2+jphi) + Vsubcontr(iphi,jphi) * basal_trac(i,j) + 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) * basal_trac(i,j) + v_diagonal(I-2+iphi,J-2+jphi) = v_diagonal(I-2+iphi,J-2+jphi) + Vsubcontr(iphi,jphi) * basal_trac(i,j) endif enddo ; enddo endif @@ -2578,8 +2572,8 @@ subroutine CG_diagonal_subgrid_basal (Phisub, H_node, DXDYH, bathyT, dens_ratio, 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) + hloc = (Phisub(i,j,1,1,qx,qy)*H_node(1,1) + Phisub(i,j,2,2,qx,qy)*H_node(2,2)) + & + (Phisub(i,j,1,2,qx,qy)*H_node(1,2) + Phisub(i,j,2,1,qx,qy)*H_node(2,1)) if (dens_ratio * hloc - bathyT > 0) then Ucontr(m,n) = Ucontr(m,n) + subarea * 0.25 * Phisub(i,j,m,n,qx,qy)**2 @@ -2609,11 +2603,10 @@ subroutine apply_boundary_values(CS, ISS, G, US, time, Phisub, H_node, ice_visc, real, dimension(SZDIB_(G),SZDJB_(G)), & intent(in) :: ice_visc !< A field related to the ice viscosity from Glen's !! flow law. The exact form and units depend on the - !! basal law exponent. + !! basal law exponent. [R L4 Z T-1 ~> kg m2 s-1]. real, dimension(SZDIB_(G),SZDJB_(G)), & intent(in) :: basal_trac !< A field related to the nonlinear part of the - !! "linearized" basal stress. The exact form and - !! units depend on the basal law exponent [L-2 ~> m-2] + !! "linearized" basal stress [R Z T-1 ~> kg m-2 s-1]. 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. @@ -2646,8 +2639,8 @@ subroutine apply_boundary_values(CS, ISS, G, US, time, Phisub, H_node, ice_visc, ! 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 + 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 call bilinear_shape_fn_grid(G, i, j, Phi) @@ -2656,58 +2649,58 @@ subroutine apply_boundary_values(CS, ISS, G, US, time, Phisub, H_node, ice_visc, do iq=1,2 ; do jq=1,2 - uq = CS%u_bdry_val(i-1,j-1) * xquad(3-iq) * xquad(3-jq) + & - CS%u_bdry_val(i,j-1) * xquad(iq) * xquad(3-jq) + & - CS%u_bdry_val(i-1,j) * xquad(3-iq) * xquad(jq) + & - CS%u_bdry_val(i,j) * xquad(iq) * xquad(jq) + uq = CS%u_bdry_val(I-1,J-1) * xquad(3-iq) * xquad(3-jq) + & + CS%u_bdry_val(I,J-1) * xquad(iq) * xquad(3-jq) + & + CS%u_bdry_val(I-1,J) * xquad(3-iq) * xquad(jq) + & + CS%u_bdry_val(I,J) * xquad(iq) * xquad(jq) - vq = CS%v_bdry_val(i-1,j-1) * xquad(3-iq) * xquad(3-jq) + & - CS%v_bdry_val(i,j-1) * xquad(iq) * xquad(3-jq) + & - CS%v_bdry_val(i-1,j) * xquad(3-iq) * xquad(jq) + & - CS%v_bdry_val(i,j) * xquad(iq) * xquad(jq) + vq = CS%v_bdry_val(I-1,J-1) * xquad(3-iq) * xquad(3-jq) + & + CS%v_bdry_val(I,J-1) * xquad(iq) * xquad(3-jq) + & + CS%v_bdry_val(I-1,J) * xquad(3-iq) * xquad(jq) + & + CS%v_bdry_val(I,J) * xquad(iq) * xquad(jq) - ux = CS%u_bdry_val(i-1,j-1) * Phi(1,2*(jq-1)+iq) + & - CS%u_bdry_val(i,j-1) * Phi(3,2*(jq-1)+iq) + & - 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) + 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) + 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) + 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) + 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 ilq = 1 ; if (iq == iphi) ilq = 2 jlq = 1 ; if (jq == jphi) jlq = 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) + & - 0.25 * G%areaT(i,j) * ice_visc(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 (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) + & + 0.25 * ice_visc(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) + & + u_bdry_contr(I-2+iphi,J-2+jphi) = u_bdry_contr(I-2+iphi,J-2+jphi) + & 0.25 * basal_trac(i,j) * G%areaT(i,j) * 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) + & - 0.25 * G%areaT(i,j) * ice_visc(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 (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) + & + 0.25 * ice_visc(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) + & + v_bdry_contr(I-2+iphi,J-2+jphi) = v_bdry_contr(I-2+iphi,J-2+jphi) + & 0.25 * basal_trac(i,j) * G%areaT(i,j) * vq * xquad(ilq) * xquad(jlq) endif endif @@ -2721,12 +2714,12 @@ subroutine apply_boundary_values(CS, ISS, G, US, time, Phisub, H_node, ice_visc, call CG_action_subgrid_basal(Phisub, Hcell, Ucell, Vcell, G%areaT(i,j), G%bathyT(i,j), & 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) + & + 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) * basal_trac(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) + & + 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) * basal_trac(i,j) endif enddo ; enddo @@ -2739,15 +2732,15 @@ 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, US, u_shlf, v_shlf) - 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. - type(unit_scale_type), intent(in) :: US !< A structure containing unit conversion factors + 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. + type(unit_scale_type), intent(in) :: US !< A structure containing unit conversion factors real, dimension(G%IsdB:G%IedB,G%JsdB:G%JedB), & - intent(inout) :: u_shlf !< The zonal ice shelf velocity [L T-1 ~> m s-1]. + intent(inout) :: u_shlf !< The zonal ice shelf velocity [L T-1 ~> m s-1]. real, dimension(G%IsdB:G%IedB,G%JsdB:G%JedB), & - intent(inout) :: v_shlf !< The meridional ice shelf velocity [L T-1 ~> m s-1]. + intent(inout) :: v_shlf !< The meridional ice shelf velocity [L T-1 ~> m s-1]. ! update DEPTH_INTEGRATED viscosity, based on horizontal strain rates - this is for bilinear FEM solve ! so there is an "upper" and "lower" bilinear viscosity @@ -2782,12 +2775,12 @@ subroutine calc_shelf_visc(CS, ISS, G, US, u_shlf, v_shlf) vx = ((v_shlf(I,J) + v_shlf(I,J-1)) - (v_shlf(I-1,J) + v_shlf(I-1,J-1))) / (2*G%dxT(i,j)) uy = ((u_shlf(I,J) + u_shlf(I-1,J)) - (u_shlf(I,J-1) + u_shlf(I-1,J-1))) / (2*G%dyT(i,j)) vy = ((v_shlf(I,J) + v_shlf(I-1,J)) - (v_shlf(I,J-1) + v_shlf(I-1,J-1))) / (2*G%dyT(i,j)) - CS%ice_visc(i,j) = 0.5 * Visc_coef * ISS%h_shelf(i,j) * & + CS%ice_visc(i,j) = 0.5 * Visc_coef * (G%areaT(i,j) * ISS%h_shelf(i,j)) * & (US%s_to_T**2 * (ux**2 + vy**2 + ux*vy + 0.25*(uy+vx)**2 + eps_min**2))**((1.-n_g)/(2.*n_g)) umid = ((u_shlf(I,J) + u_shlf(I-1,J-1)) + (u_shlf(I,J-1) + u_shlf(I-1,J))) * 0.25 vmid = ((v_shlf(I,J) + v_shlf(I-1,J-1)) + (v_shlf(I,J-1) + v_shlf(I-1,J))) * 0.25 - unorm = sqrt(umid**2 + vmid**2 + (eps_min*G%dxT(i,j))**2) + unorm = sqrt(umid**2 + vmid**2 + eps_min**2*(G%dxT(i,j)**2 + G%dyT(i,j)**2)) CS%basal_traction(i,j) = CS%C_basal_friction * (US%L_T_to_m_s*unorm)**(CS%n_basal_fric-1) endif enddo @@ -3086,90 +3079,90 @@ subroutine update_velocity_masks(CS, G, hmask, umask, vmask, u_face_mask, v_face if (hmask(i,j) == 1) then - umask(i-1:i,j-1:j) = 1. - vmask(i-1:i,j-1:j) = 1. + 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))) + 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. + 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. + 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. + 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. + 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. + 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))) + 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. + 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. + 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. + 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. + umask(I-1:I,J-1+k)=0. + vmask(I-1:I,J-1+k)=0. + v_face_mask(i,J-1+k)=0. case (1) ! stress free y-boundary - vmask(i-1:i,j-1+k)=0. + vmask(I-1:I,J-1+k)=0. case default end select enddo - !if (CS%u_face_mask_bdry(i-1,j) >= 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. + !if (CS%u_face_mask_bdry(I-1,j) >= 0) then ! Western 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. + !if (j_off+j == gjsc+1) then ! SoutherN 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 ! Northern 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. + 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. + 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. + v_face_mask(i,J-1) = 2. endif endif @@ -3435,7 +3428,7 @@ subroutine ice_shelf_advect_temp_x(CS, G, time_step, hmask, h0, h_after_uflux, f logical :: at_east_bdry, at_west_bdry, one_off_west_bdry, one_off_east_bdry real, dimension(-2:2) :: stencil real :: u_face ! Zonal velocity at a face, positive if out {L T-1 ~> m s-1] - real :: flux_diff_cell, phi + real :: flux_diff, phi character (len=1) :: debug_str @@ -3472,18 +3465,18 @@ subroutine ice_shelf_advect_temp_x(CS, G, time_step, hmask, h0, h_after_uflux, f stencil(:) = h0(i-2:i+2,j) ! fine as long has nx_halo >= 2 - flux_diff_cell = 0 + flux_diff = 0 ! 1ST DO LEFT FACE - if (CS%u_face_mask(i-1,j) == 4.) then + if (CS%u_face_mask(I-1,j) == 4.) then - flux_diff_cell = flux_diff_cell + G%dyT(i,j) * time_step * CS%u_flux_bdry_val(i-1,j) * & + flux_diff = flux_diff + G%dyCu(I-1,j) * time_step * CS%u_flux_bdry_val(I-1,j) * & CS%t_bdry_val(i-1,j) / G%areaT(i,j) 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)) + 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 @@ -3491,32 +3484,32 @@ subroutine ice_shelf_advect_temp_x(CS, G, time_step, hmask, h0, h_after_uflux, f 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) * G%dyT(i,j) * time_step * stencil(-1) / G%areaT(i,j) + flux_diff = flux_diff + ABS(u_face) * G%dyCu(I-1,j) * time_step * stencil(-1) / G%areaT(i,j) 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) * G%dyT(i,j)* time_step / G%areaT(i,j) * & + flux_diff = flux_diff + ABS(u_face) * G%dyCu(I-1,j)* time_step / G%areaT(i,j) * & (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) * G%dyT(i,j) * time_step / G%areaT(i,j) * stencil(-1) + flux_diff = flux_diff + ABS(u_face) * G%dyCu(I-1,j) * time_step / G%areaT(i,j) * 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) * G%dyT(i,j) * time_step / G%areaT(i,j) * & + flux_diff = flux_diff - ABS(u_face) * G%dyCu(I-1,j) * time_step / G%areaT(i,j) * & (stencil(0) - phi * (stencil(0)-stencil(-1))/2) else - flux_diff_cell = flux_diff_cell - ABS(u_face) * G%dyT(i,j) * time_step / G%areaT(i,j) * stencil(0) + flux_diff = flux_diff - ABS(u_face) * G%dyCu(I-1,j) * time_step / G%areaT(i,j) * stencil(0) if ((hmask(i-1,j) == 0) .OR. (hmask(i-1,j) == 2)) then - flux_enter(i-1,j,2) = ABS(u_face) * G%dyT(i,j) * time_step * stencil(0) + flux_enter(i-1,j,2) = ABS(u_face) * G%dyCu(I-1,j) * time_step * stencil(0) endif endif endif @@ -3526,32 +3519,32 @@ subroutine ice_shelf_advect_temp_x(CS, G, time_step, hmask, h0, h_after_uflux, f ! get u-velocity at center of right face - if (CS%u_face_mask(i+1,j) == 4.) then + if (CS%u_face_mask(I+1,j) == 4.) then - flux_diff_cell = flux_diff_cell + G%dyT(i,j) * time_step * CS%u_flux_bdry_val(i+1,j) *& + flux_diff = flux_diff + G%dyCu(I,j) * time_step * CS%u_flux_bdry_val(I+1,j) *& CS%t_bdry_val(i+1,j) / G%areaT(i,j) else - u_face = 0.5 * (CS%u_shelf(i,j-1) + CS%u_shelf(i,j)) + 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) * G%dyT(i,j) * time_step * stencil(1) / G%areaT(i,j) + flux_diff = flux_diff + ABS(u_face) * G%dyCu(I,j) * time_step * stencil(1) / G%areaT(i,j) 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) * G%dyT(i,j) * time_step / G%areaT(i,j) * & + flux_diff = flux_diff + ABS(u_face) * G%dyCu(I,j) * time_step / G%areaT(i,j) * & (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) * G%dyT(i,j) * time_step / G%areaT(i,j) * stencil(1) + flux_diff = flux_diff + ABS(u_face) * G%dyCu(I,j) * time_step / G%areaT(i,j) * stencil(1) endif @@ -3560,44 +3553,44 @@ subroutine ice_shelf_advect_temp_x(CS, G, time_step, hmask, h0, h_after_uflux, f 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) * G%dyT(i,j) * time_step / G%areaT(i,j) * & + flux_diff = flux_diff - ABS(u_face) * G%dyCu(I,j) * time_step / G%areaT(i,j) * & (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) * G%dyT(i,j) * time_step / G%areaT(i,j) * stencil(0) + flux_diff = flux_diff - ABS(u_face) * G%dyCu(I,j) * time_step / G%areaT(i,j) * stencil(0) if ((hmask(i+1,j) == 0) .OR. (hmask(i+1,j) == 2)) then - flux_enter(i+1,j,1) = ABS(u_face) * G%dyT(i,j) * time_step * stencil(0) + flux_enter(i+1,j,1) = ABS(u_face) * G%dyCu(I,j) * time_step * stencil(0) endif endif endif - h_after_uflux(i,j) = h_after_uflux(i,j) + flux_diff_cell + h_after_uflux(i,j) = h_after_uflux(i,j) + flux_diff 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) * & + 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%dyCu(I-1,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) + elseif (CS%u_face_mask(I-1,j) == 4.) then + flux_enter(i,j,1) = G%dyCu(I-1,j) * time_step * CS%u_flux_bdry_val(I-1,j)*CS%t_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%t_bdry_val(i+1,j)* & + u_face = 0.5 * (CS%u_shelf(I,J-1) + CS%u_shelf(I,J)) + flux_enter(i,j,2) = ABS(u_face) * G%dyCu(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) + elseif (CS%u_face_mask(I+1,j) == 4.) then + flux_enter(i,j,2) = G%dyCu(I,j) * time_step * CS%u_flux_bdry_val(I+1,j) * CS%t_bdry_val(i+1,j) endif ! if ((i == is) .AND. (hmask(i,j) == 0) .AND. (hmask(i-1,j) == 1)) then @@ -3665,7 +3658,7 @@ subroutine ice_shelf_advect_temp_y(CS, G, time_step, hmask, h_after_uflux, h_aft logical :: at_north_bdry, at_south_bdry, one_off_west_bdry, one_off_east_bdry real, dimension(-2:2) :: stencil real :: v_face ! Pseudo-meridional velocity at a cell face, positive if out {L T-1 ~> m s-1] - real :: flux_diff_cell, phi + real :: flux_diff, phi character(len=1) :: debug_str is = G%isc ; ie = G%iec ; js = G%jsc-1 ; je = G%jec+1 ; isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed @@ -3697,18 +3690,18 @@ subroutine ice_shelf_advect_temp_y(CS, G, time_step, hmask, h_after_uflux, h_aft 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 + flux_diff = 0 ! 1ST DO south FACE - if (CS%v_face_mask(i,j-1) == 4.) then + if (CS%v_face_mask(i,J-1) == 4.) then - flux_diff_cell = flux_diff_cell + G%dxT(i,j) * time_step * CS%v_flux_bdry_val(i,j-1) * & + flux_diff = flux_diff + G%dxCv(i,J-1) * time_step * CS%v_flux_bdry_val(i,J-1) * & CS%t_bdry_val(i,j-1)/ G%areaT(i,j) 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)) + 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 @@ -3716,32 +3709,31 @@ subroutine ice_shelf_advect_temp_y(CS, G, time_step, hmask, h_after_uflux, h_aft 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) * G%dxT(i,j) * time_step * stencil(-1) / G%areaT(i,j) + flux_diff = flux_diff + ABS(v_face) * G%dxCv(i,J-1) * time_step * stencil(-1) / G%areaT(i,j) 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) * G%dxT(i,j) * time_step / G%areaT(i,j) * & + flux_diff = flux_diff + ABS(v_face) * G%dxCv(i,J-1) * time_step / G%areaT(i,j) * & (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) * G%dxT(i,j) * time_step / G%areaT(i,j) * stencil(-1) + flux_diff = flux_diff + ABS(v_face) * G%dxCv(i,J-1) * time_step / G%areaT(i,j) * 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) * G%dxT(i,j) * time_step / G%areaT(i,j) * & + flux_diff = flux_diff - ABS(v_face) * G%dxCv(i,J-1) * time_step / G%areaT(i,j) * & (stencil(0) - phi * (stencil(0)-stencil(-1))/2) else - flux_diff_cell = flux_diff_cell - ABS(v_face) * G%dxT(i,j) * time_step / G%areaT(i,j) * stencil(0) + flux_diff = flux_diff - ABS(v_face) * G%dxCv(i,J-1) * time_step / G%areaT(i,j) * stencil(0) - !### The G%dyT(i,j) below needs to be G%dxCv(i,J) if ((hmask(i,j-1) == 0) .OR. (hmask(i,j-1) == 2)) then - flux_enter(i,j-1,4) = ABS(v_face) * G%dyT(i,j) * time_step * stencil(0) + flux_enter(i,j-1,4) = ABS(v_face) * G%dxCv(i,J-1) * time_step * stencil(0) endif endif @@ -3752,42 +3744,42 @@ subroutine ice_shelf_advect_temp_y(CS, G, time_step, hmask, h_after_uflux, h_aft ! NEXT DO north FACE - if (CS%v_face_mask(i,j+1) == 4.) then + if (CS%v_face_mask(i,J+1) == 4.) then - flux_diff_cell = flux_diff_cell + G%dxT(i,j) * time_step * CS%v_flux_bdry_val(i,j+1) *& + flux_diff = flux_diff + G%dxCv(i,J) * time_step * CS%v_flux_bdry_val(i,J+1) *& CS%t_bdry_val(i,j+1)/ G%areaT(i,j) else ! get u-velocity at center of right face - v_face = 0.5 * (CS%v_shelf(i-1,j) + CS%v_shelf(i,j)) + 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) * G%dxT(i,j) * time_step * stencil(1) / G%areaT(i,j) + flux_diff = flux_diff + ABS(v_face) * G%dxCv(i,J) * time_step * stencil(1) / G%areaT(i,j) 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) * G%dxT(i,j) * time_step / G%areaT(i,j) * & + flux_diff = flux_diff + ABS(v_face) * G%dxCv(i,J) * time_step / G%areaT(i,j) * & (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) * G%dxT(i,j) * time_step / G%areaT(i,j) * stencil(1) + flux_diff = flux_diff + ABS(v_face) * G%dxCv(i,J) * time_step / G%areaT(i,j) * 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) * G%dxT(i,j) * time_step / G%areaT(i,j) * & + flux_diff = flux_diff - ABS(v_face) * G%dxCv(i,J) * time_step / G%areaT(i,j) * & (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) * G%dxT(i,j) * time_step / G%areaT(i,j) * stencil(0) + flux_diff = flux_diff - ABS(v_face) * G%dxCv(i,J) * time_step / G%areaT(i,j) * stencil(0) if ((hmask(i,j+1) == 0) .OR. (hmask(i,j+1) == 2)) then - flux_enter(i,j+1,3) = ABS(v_face) * G%dxT(i,j) * time_step * stencil(0) + flux_enter(i,j+1,3) = ABS(v_face) * G%dxCv(i,J) * time_step * stencil(0) endif endif @@ -3795,24 +3787,24 @@ subroutine ice_shelf_advect_temp_y(CS, G, time_step, hmask, h_after_uflux, h_aft endif - h_after_vflux(i,j) = h_after_vflux(i,j) + flux_diff_cell + h_after_vflux(i,j) = h_after_vflux(i,j) + flux_diff 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)* & + 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%dxCv(i,J-1) * 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) + elseif (CS%v_face_mask(i,J-1) == 4.) then + flux_enter(i,j,3) = G%dxCv(i,J-1) * time_step * CS%v_flux_bdry_val(i,J-1)*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)* & + v_face = 0.5 * (CS%v_shelf(I-1,J) + CS%v_shelf(I,J)) + flux_enter(i,j,4) = ABS(v_face) * G%dxCv(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) + elseif (CS%v_face_mask(i,J+1) == 4.) then + flux_enter(i,j,4) = G%dxCv(i,J) * time_step * CS%v_flux_bdry_val(i,J+1)*CS%t_bdry_val(i,j+1) endif ! if ((j == js) .AND. (hmask(i,j) == 0) .AND. (hmask(i,j-1) == 1)) then From 6fd0edf2f89687381e54e7c861d5487873d01740 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 26 Mar 2020 10:23:10 -0400 Subject: [PATCH 126/316] (*)Fixed spatial index errors in ice_shelf_advect Corrected spatial indexing errors associated with open boundary condition fluxes in the four ice_shelf_advect routines. This could change answers in some cases, but these errors seem likely to lead to segmentation faults in such cases, so it is entirely possible that this code has never been exercised. Also revised the directional nomenclature in some comments. All answers are bitwise identical in the MOM6-examples test cases, but it should be noted that there are no active tests of the ice shelf dynamics code. --- src/ice_shelf/MOM_ice_shelf_dynamics.F90 | 113 +++++++++++------------ 1 file changed, 56 insertions(+), 57 deletions(-) diff --git a/src/ice_shelf/MOM_ice_shelf_dynamics.F90 b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 index 0aae1d35f8..8fa014c57f 100644 --- a/src/ice_shelf/MOM_ice_shelf_dynamics.F90 +++ b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 @@ -709,10 +709,10 @@ subroutine ice_shelf_advect(CS, ISS, G, time_step, Time) ! ###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) + ! from eastern neighbor: flux_enter(:,:,1) + ! from western neighbor: flux_enter(:,:,2) + ! from southern neighbor: flux_enter(:,:,3) + ! from northern neighbor: flux_enter(:,:,4) ! ! THESE ARE NOT CONSISTENT ==> FIND OUT WHAT YOU IMPLEMENTED @@ -1329,10 +1329,10 @@ subroutine ice_shelf_advect_thickness_x(CS, G, time_step, hmask, h0, h_after_ufl ! 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) + ! from eastern neighbor: flux_enter(:,:,1) + ! from western neighbor: flux_enter(:,:,2) + ! from southern neighbor: flux_enter(:,:,3) + ! from northern neighbor: flux_enter(:,:,4) ! ! o--- (4) ---o ! | | @@ -1433,11 +1433,11 @@ subroutine ice_shelf_advect_thickness_x(CS, G, time_step, hmask, h0, h_after_ufl ! NEXT DO RIGHT FACE - ! get u-velocity at center of right face + ! get u-velocity at center of east face - if (CS%u_face_mask(I+1,j) == 4.) then + if (CS%u_face_mask(I,j) == 4.) then - flux_diff = flux_diff + G%dyCu(I,j) * time_step * CS%u_flux_bdry_val(I+1,j) / G%areaT(i,j) + flux_diff = flux_diff + G%dyCu(I,j) * time_step * CS%u_flux_bdry_val(I,j) / G%areaT(i,j) else @@ -1502,8 +1502,8 @@ subroutine ice_shelf_advect_thickness_x(CS, G, time_step, hmask, h0, h_after_ufl 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%dyCu(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%dyCu(I,j) * time_step * CS%u_flux_bdry_val(I+1,j) + elseif (CS%u_face_mask(I,j) == 4.) then + flux_enter(i,j,2) = G%dyCu(I,j) * time_step * CS%u_flux_bdry_val(I,j) endif if ((i == is) .AND. (hmask(i,j) == 0) .AND. (hmask(i-1,j) == 1)) then @@ -1556,10 +1556,10 @@ subroutine ice_shelf_advect_thickness_y(CS, G, time_step, hmask, h_after_uflux, ! 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) + ! from eastern neighbor: flux_enter(:,:,1) + ! from western neighbor: flux_enter(:,:,2) + ! from southern neighbor: flux_enter(:,:,3) + ! from northern neighbor: flux_enter(:,:,4) ! ! o--- (4) ---o ! | | @@ -1661,9 +1661,9 @@ subroutine ice_shelf_advect_thickness_y(CS, G, time_step, hmask, h_after_uflux, ! NEXT DO north FACE - if (CS%v_face_mask(i,J+1) == 4.) then + if (CS%v_face_mask(i,J) == 4.) then - flux_diff = flux_diff + G%dxCv(i,J) * time_step * CS%v_flux_bdry_val(i,J+1) / G%areaT(i,j) + flux_diff = flux_diff + G%dxCv(i,J) * time_step * CS%v_flux_bdry_val(i,J) / G%areaT(i,j) else @@ -1718,8 +1718,8 @@ subroutine ice_shelf_advect_thickness_y(CS, G, time_step, hmask, h_after_uflux, 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%dxCv(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%dxCv(i,J) * time_step * CS%v_flux_bdry_val(i,J+1) + elseif (CS%v_face_mask(i,J) == 4.) then + flux_enter(i,j,4) = G%dxCv(i,J) * time_step * CS%v_flux_bdry_val(i,J) endif if ((j == js) .AND. (hmask(i,j) == 0) .AND. (hmask(i,j-1) == 1)) then @@ -1766,10 +1766,10 @@ subroutine shelf_advance_front(CS, ISS, G, flux_enter) ! 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) + ! from eastern neighbor: flux_enter(:,:,1) + ! from western neighbor: flux_enter(:,:,2) + ! from southern neighbor: flux_enter(:,:,3) + ! from northern neighbor: flux_enter(:,:,4) ! ! o--- (4) ---o ! | | @@ -2042,7 +2042,7 @@ subroutine calc_shelf_driving_stress(CS, ISS, G, US, taudx, taudy, OD) else sx = 0 endif - elseif ((i+i_off) == giec) then ! at right computational bdry + elseif ((i+i_off) == giec) then ! at east computational bdry if (ISS%hmask(i-1,j) == 1) then sx = (S(i,j)-S(i-1,j))/dxh else @@ -2140,7 +2140,7 @@ subroutine calc_shelf_driving_stress(CS, ISS, G, US, taudx, taudy, OD) 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 + ! east face of the cell is at a stress boundary taudx(I,J-1) = taudx(I,J-1) + .5 * dyh * neumann_val taudx(I,J) = taudx(I,J) + .5 * dyh * neumann_val endif @@ -3145,9 +3145,8 @@ subroutine update_velocity_masks(CS, G, hmask, umask, vmask, u_face_mask, v_face !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 + if ((hmask(i+1,j) == 0) .OR. (hmask(i+1,j) == 2)) then + ! east boundary or adjacent to unfilled cell u_face_mask(I,j) = 2. endif endif @@ -3278,10 +3277,10 @@ subroutine ice_shelf_temp(CS, ISS, G, US, time_step, melt_rate, Time) ! ###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) + ! from eastern neighbor: flux_enter(:,:,1) + ! from western neighbor: flux_enter(:,:,2) + ! from southern neighbor: flux_enter(:,:,3) + ! from northern neighbor: flux_enter(:,:,4) ! ! THESE ARE NOT CONSISTENT ==> FIND OUT WHAT YOU IMPLEMENTED @@ -3411,10 +3410,10 @@ subroutine ice_shelf_advect_temp_x(CS, G, time_step, hmask, h0, h_after_uflux, f ! 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) + ! from eastern neighbor: flux_enter(:,:,1) + ! from western neighbor: flux_enter(:,:,2) + ! from southern neighbor: flux_enter(:,:,3) + ! from northern neighbor: flux_enter(:,:,4) ! ! o--- (4) ---o ! | | @@ -3517,11 +3516,11 @@ subroutine ice_shelf_advect_temp_x(CS, G, time_step, hmask, h0, h_after_uflux, f ! NEXT DO RIGHT FACE - ! get u-velocity at center of right face + ! get u-velocity at center of eastern face - if (CS%u_face_mask(I+1,j) == 4.) then + if (CS%u_face_mask(I,j) == 4.) then - flux_diff = flux_diff + G%dyCu(I,j) * time_step * CS%u_flux_bdry_val(I+1,j) *& + flux_diff = flux_diff + G%dyCu(I,j) * time_step * CS%u_flux_bdry_val(I,j) *& CS%t_bdry_val(i+1,j) / G%areaT(i,j) else @@ -3589,18 +3588,18 @@ subroutine ice_shelf_advect_temp_x(CS, G, time_step, hmask, h0, h_after_uflux, f u_face = 0.5 * (CS%u_shelf(I,J-1) + CS%u_shelf(I,J)) flux_enter(i,j,2) = ABS(u_face) * G%dyCu(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%dyCu(I,j) * time_step * CS%u_flux_bdry_val(I+1,j) * CS%t_bdry_val(i+1,j) + elseif (CS%u_face_mask(I,j) == 4.) then + flux_enter(i,j,2) = G%dyCu(I,j) * time_step * CS%u_flux_bdry_val(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 + ! the front without having to call pass_var - if cell is empty and cell to west ! 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 + ! the front without having to call pass_var - if cell is empty and cell to west ! is ice-covered then this cell will become partly covered ! hmask(i,j) = 2 @@ -3641,10 +3640,10 @@ subroutine ice_shelf_advect_temp_y(CS, G, time_step, hmask, h_after_uflux, h_aft ! 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) + ! from eastern neighbor: flux_enter(:,:,1) + ! from western neighbor: flux_enter(:,:,2) + ! from southern neighbor: flux_enter(:,:,3) + ! from northern neighbor: flux_enter(:,:,4) ! ! o--- (4) ---o ! | | @@ -3700,7 +3699,7 @@ subroutine ice_shelf_advect_temp_y(CS, G, time_step, hmask, h_after_uflux, h_aft CS%t_bdry_val(i,j-1)/ G%areaT(i,j) else - ! get u-velocity at center of left face + ! get u-velocity at center of west 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 @@ -3744,13 +3743,13 @@ subroutine ice_shelf_advect_temp_y(CS, G, time_step, hmask, h_after_uflux, h_aft ! NEXT DO north FACE - if (CS%v_face_mask(i,J+1) == 4.) then + if (CS%v_face_mask(i,J) == 4.) then - flux_diff = flux_diff + G%dxCv(i,J) * time_step * CS%v_flux_bdry_val(i,J+1) *& + flux_diff = flux_diff + G%dxCv(i,J) * time_step * CS%v_flux_bdry_val(i,J) *& CS%t_bdry_val(i,j+1)/ G%areaT(i,j) else - ! get u-velocity at center of right face + ! get u-velocity at center of east 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 @@ -3803,18 +3802,18 @@ subroutine ice_shelf_advect_temp_y(CS, G, time_step, hmask, h_after_uflux, h_aft v_face = 0.5 * (CS%v_shelf(I-1,J) + CS%v_shelf(I,J)) flux_enter(i,j,4) = ABS(v_face) * G%dxCv(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%dxCv(i,J) * time_step * CS%v_flux_bdry_val(i,J+1)*CS%t_bdry_val(i,j+1) + elseif (CS%v_face_mask(i,J) == 4.) then + flux_enter(i,j,4) = G%dxCv(i,J) * time_step * CS%v_flux_bdry_val(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 + ! the front without having to call pass_var - if cell is empty and cell to west ! 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 + ! front without having to call pass_var - if cell is empty and cell to west is ! ice-covered then this cell will become partly covered ! hmask(i,j) = 2 ! endif From 5fb71b1072c6e4311e1b1d82e6a36991583cfe32 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 27 Mar 2020 15:08:21 -0400 Subject: [PATCH 127/316] +Revised routines in ice_shelf_advect Extensively revised the ice_shelf_advect_thickness and shelf_advance_front routines, avoiding the use of the flux_enter as arguments between routines. Also folded the area into the definition of CS%basal_traction. Also corrected distributed spelling errors and added local variables to avoid repetitious complicated index constructs. All answers are bitwise identical in the MOM6-examples test cases, but it should be noted that there are no active tests of the ice shelf dynamics code. --- src/ice_shelf/MOM_ice_shelf_dynamics.F90 | 1008 ++++++---------------- 1 file changed, 281 insertions(+), 727 deletions(-) diff --git a/src/ice_shelf/MOM_ice_shelf_dynamics.F90 b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 index 8fa014c57f..f9d272b16e 100644 --- a/src/ice_shelf/MOM_ice_shelf_dynamics.F90 +++ b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 @@ -49,7 +49,7 @@ module MOM_ice_shelf_dynamics !! 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 + !! 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) real, pointer, dimension(:,:) :: v_face_mask => NULL() !< A mask for velocity boundary conditions on the C-grid @@ -60,7 +60,7 @@ module MOM_ice_shelf_dynamics !! through open boundary u-faces (where u_face_mask=4) [Z L T-1 ~> m2 s-1] real, pointer, dimension(:,:) :: v_flux_bdry_val => NULL() !< The ice volume flux per unit face length into the cell !! through open boundary v-faces (where v_face_mask=4) [Z L T-1 ~> m2 s-1]?? - ! needed where u_face_mask is equal to 4, similary for v_face_mask + ! needed where u_face_mask is equal to 4, similarly for v_face_mask real, pointer, dimension(:,:) :: umask => NULL() !< u-mask 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) @@ -69,7 +69,7 @@ module MOM_ice_shelf_dynamics !! 0 - no flow node (will also get ice-free nodes) real, pointer, dimension(:,:) :: calve_mask => NULL() !< a mask to prevent the ice shelf front from !! advancing past its initial position (but it may retreat) - real, pointer, dimension(:,:) :: t_shelf => NULL() !< Veritcally integrated temperature in the ice shelf/stream, + real, pointer, dimension(:,:) :: t_shelf => NULL() !< Vertically integrated temperature in the ice shelf/stream, !! on corner-points (B grid) [degC] real, pointer, dimension(:,:) :: tmask => NULL() !< A mask on tracer points that is 1 where there is ice. real, pointer, dimension(:,:) :: ice_visc => NULL() !< Glen's law ice viscosity, often in [R L4 Z T-1 ~> kg m2 s-1]. @@ -81,8 +81,8 @@ module MOM_ice_shelf_dynamics real, pointer, dimension(:,:) :: h_bdry_val => NULL() !< The ice thickness at inflowing boundaries [m]. real, pointer, dimension(:,:) :: t_bdry_val => NULL() !< The ice temperature at inflowing boundaries [degC]. - real, pointer, dimension(:,:) :: basal_traction => NULL() !< The nonlinear part of "linearized" - !! basal stress [R Z T-1 ~> kg m-2 s-1]. + real, pointer, dimension(:,:) :: basal_traction => NULL() !< The area integrated nonlinear part of "linearized" + !! basal stress [R Z L2 T-1 ~> kg s-1]. !! The exact form depends on basal law exponent and/or whether flow is "hybridized" a la Goldberg 2011 real, pointer, dimension(:,:) :: OD_rt => NULL() !< A running total for calculating OD_av. @@ -97,9 +97,9 @@ module MOM_ice_shelf_dynamics !! using the nonlinear elliptic equation, or 0 to update every timestep [T ~> s]. ! 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 + ! this time interval, and solving for the equilibrated 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 updated [T ~> s]. + real :: elapsed_velocity_time !< The elapsed time since the ice velocities were last updated [T ~> s]. real :: g_Earth !< The gravitational acceleration [L2 Z-1 T-2 ~> m s-2]. real :: density_ice !< A typical density of ice [R ~> kg m-3]. @@ -135,7 +135,7 @@ module MOM_ice_shelf_dynamics real :: min_thickness_simple_calve !< min. ice shelf thickness criteria for calving [Z ~> m]. real :: cg_tolerance !< The tolerance in the CG solver, relative to initial residual, that - !! deterimnes when to stop the conguage gradient iterations. + !! determines when to stop the conjugate gradient iterations. real :: nonlinear_tolerance !< The fractional nonlinear tolerance, relative to the initial error, !! that sets when to stop the iterative velocity solver integer :: cg_max_iterations !< The maximum number of iterations that can be used in the CG solver @@ -161,6 +161,13 @@ module MOM_ice_shelf_dynamics end type ice_shelf_dyn_CS +!> A container for loop bounds +type :: loop_bounds_type ; private + !>@{ Loop bounds + integer :: ish, ieh, jsh, jeh + !>@} +end type loop_bounds_type + contains !> used for flux limiting in advective subroutines Van Leer limiter (source: Wikipedia) @@ -257,7 +264,7 @@ subroutine register_ice_shelf_dyn_restarts(G, param_file, CS, restart_CS) call register_restart_field(CS%ice_visc, "viscosity", .true., restart_CS, & "Volume integrated Glens law ice viscosity", "kg m2 s-1") call register_restart_field(CS%basal_traction, "tau_b_beta", .true., restart_CS, & - "Coefficient of basal traction", "kg m-2 s-1") + "The area integrated basal traction coefficient", "kg s-1") endif end subroutine register_ice_shelf_dyn_restarts @@ -397,8 +404,7 @@ subroutine initialize_ice_shelf_dyn(param_file, Time, ISS, CS, G, US, diag, new_ "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, & + 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, scale=US%m_to_Z) @@ -590,7 +596,7 @@ subroutine initialize_diagnostic_fields(CS, ISS, G, US, Time) end subroutine initialize_diagnostic_fields !> This function returns the global maximum advective timestep that can be taken based on the current -!! ice velocities. Because it involves finding a global minimum, it can be suprisingly expensive. +!! ice velocities. Because it involves finding a global minimum, it can be surprisingly 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 @@ -703,36 +709,17 @@ subroutine ice_shelf_advect(CS, ISS, G, time_step, Time) ! 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 eastern neighbor: flux_enter(:,:,1) - ! from western neighbor: flux_enter(:,:,2) - ! from southern neighbor: flux_enter(:,:,3) - ! from northern 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 ! Ice thicknesses [Z ~> m]. - real, dimension(SZDI_(G),SZDJ_(G),4) :: flux_enter ! The ice volume flux into the cell - ! through the 4 cell boundaries [Z L2 ~> m3]. - integer :: isd, ied, jsd, jed, i, j, isc, iec, jsc, jec + real, dimension(SZDIB_(G),SZDJ_(G)) :: uh_ice ! The accumulated zonal ice volume flux [Z L2 ~> m3] + real, dimension(SZDI_(G),SZDJB_(G)) :: vh_ice ! The accumulated meridional ice volume flux [Z L2 ~> m3] + type(loop_bounds_type) :: LB + integer :: isd, ied, jsd, jed, i, j, isc, iec, jsc, jec, stencil 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 + + uh_ice(:,:) = 0.0 + vh_ice(:,:) = 0.0 h_after_uflux(:,:) = 0.0 h_after_vflux(:,:) = 0.0 @@ -742,14 +729,20 @@ subroutine ice_shelf_advect(CS, ISS, G, time_step, Time) ISS%h_shelf(i,j) = CS%thickness_bdry_val(i,j) endif ; enddo ; enddo - call ice_shelf_advect_thickness_x(CS, G, time_step, ISS%hmask, ISS%h_shelf, h_after_uflux, flux_enter) + stencil = 2 + LB%ish = G%isc ; LB%ieh = G%iec ; LB%jsh = G%jsc-stencil ; LB%jeh = G%jec+stencil + if (LB%jsh < jsd) call MOM_error(FATAL, & + "ice_shelf_advect: Halo is too small for the ice thickness advection stencil.") + + call ice_shelf_advect_thickness_x(CS, G, LB, time_step, ISS%hmask, ISS%h_shelf, h_after_uflux, uh_ice) ! call enable_averages(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, ISS%hmask, h_after_uflux, h_after_vflux, flux_enter) + LB%ish = G%isc ; LB%ieh = G%iec ; LB%jsh = G%jsc ; LB%jeh = G%jec + call ice_shelf_advect_thickness_y(CS, G, LB, time_step, ISS%hmask, h_after_uflux, h_after_vflux, vh_ice) ! call enable_averages(time_step, Time, CS%diag) ! call pass_var(h_after_vflux, G%domain) @@ -763,7 +756,7 @@ subroutine ice_shelf_advect(CS, ISS, G, time_step, Time) enddo if (CS%moving_shelf_front) then - call shelf_advance_front(CS, ISS, G, flux_enter) + call shelf_advance_front(CS, ISS, G, ISS%hmask, uh_ice, vh_ice) 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) @@ -777,7 +770,7 @@ subroutine ice_shelf_advect(CS, ISS, G, time_step, Time) !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, US%T_to_s*time_step, fluxes, CS%density_ice) + !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) @@ -811,7 +804,7 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u_shlf, v_shlf, iters, time) real :: err_max, err_tempu, err_tempv, err_init, area, max_vel, tempu, tempv real :: rhoi_rhow ! The density of ice divided by a typical water density [nondim] real, pointer, dimension(:,:,:,:) :: Phi => NULL() ! The gradients of bilinear basis elements at Gaussian - ! quadrature points surrounding the cell verticies [m-1]. + ! quadrature points surrounding the cell vertices [m-1]. real, pointer, dimension(:,:,:,:,:,:) :: Phisub => NULL() ! Quadrature structure weights at subgridscale ! locations for finite element calculations [nondim] character(2) :: iternum @@ -834,11 +827,10 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u_shlf, v_shlf, iters, time) call calc_shelf_driving_stress(CS, ISS, G, US, 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 + ! This is to determine which cells contain the grounding line, the criterion being that the cell + ! is ice-covered, with some nodes floating and some grounded flotation condition is estimated by + ! assuming topography is cellwise constant and H is bilinear in a cell; floating where + ! rho_i/rho_w * H_node - D is negative ! need to make this conditional on GL interp @@ -879,8 +871,7 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u_shlf, v_shlf, iters, time) call pass_var(CS%ice_visc, G%domain) call pass_var(CS%basal_traction, G%domain) - ! makes sure basal stress is only applied when it is supposed to be - + ! This makes sure basal stress is only applied when it is supposed to be do j=G%jsd,G%jed ; do i=G%isd,G%ied CS%basal_traction(i,j) = CS%basal_traction(i,j) * CS%ground_frac(i,j) enddo ; enddo @@ -932,7 +923,6 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u_shlf, v_shlf, iters, time) call pass_var(CS%basal_traction, 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%basal_traction(i,j) = CS%basal_traction(i,j) * CS%ground_frac(i,j) enddo ; enddo @@ -940,8 +930,7 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u_shlf, v_shlf, iters, time) u_bdry_cont(:,:) = 0 ; v_bdry_cont(:,:) = 0 call apply_boundary_values(CS, ISS, G, US, time, Phisub, H_node, CS%ice_visc, & - CS%basal_traction, float_cond, & - rhoi_rhow, u_bdry_cont, v_bdry_cont) + CS%basal_traction, float_cond, rhoi_rhow, u_bdry_cont, v_bdry_cont) Au(:,:) = 0 ; Av(:,:) = 0 @@ -1034,12 +1023,12 @@ subroutine ice_shelf_solve_inner(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, H 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 + !! iterations have converged to the specified tolerance integer, intent(out) :: iters !< The number of iterations used in the solver. type(time_type), intent(in) :: Time !< The current model time real, dimension(8,4,SZDI_(G),SZDJ_(G)), & intent(in) :: Phi !< The gradients of bilinear basis elements at Gaussian - !! quadrature points surrounding the cell verticies [L-1 ~> m-1]. + !! quadrature points surrounding the cell vertices [L-1 ~> m-1]. real, dimension(:,:,:,:,:,:), & intent(in) :: Phisub !< Quadrature structure weights at subgridscale !! locations for finite element calculations [nondim] @@ -1307,9 +1296,10 @@ subroutine ice_shelf_solve_inner(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, H end subroutine ice_shelf_solve_inner -subroutine ice_shelf_advect_thickness_x(CS, G, time_step, hmask, h0, h_after_uflux, flux_enter) +subroutine ice_shelf_advect_thickness_x(CS, G, LB, time_step, hmask, h0, h_after_uflux, uh_ice) 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. + type(loop_bounds_type), intent(in) :: LB !< Loop bounds structure. real, intent(in) :: time_step !< The time step for this update [T ~> s]. real, dimension(SZDI_(G),SZDJ_(G)), & intent(inout) :: hmask !< A mask indicating which tracer points are @@ -1319,437 +1309,167 @@ subroutine ice_shelf_advect_thickness_x(CS, G, time_step, hmask, h0, h_after_ufl real, dimension(SZDI_(G),SZDJ_(G)), & intent(inout) :: h_after_uflux !< The ice shelf thicknesses after !! the zonal mass fluxes [Z ~> m]. - real, dimension(SZDI_(G),SZDJ_(G),4), & - intent(inout) :: flux_enter !< The ice volume flux into the cell - !! through the 4 cell boundaries [Z L2 ~> m3]. + real, dimension(SZDIB_(G),SZDJ_(G)), & + intent(inout) :: uh_ice ! The accumulated zonal ice volume flux [Z L2 ~> 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 eastern neighbor: flux_enter(:,:,1) - ! from western neighbor: flux_enter(:,:,2) - ! from southern neighbor: flux_enter(:,:,3) - ! from northern 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 ! Thicknesses [Z ~> m]. - real :: u_face ! Zonal velocity at a face, positive if out {L Z-1 ~> m s-1] - real :: flux_diff + integer :: i, j + integer :: ish, ieh, jsh, jeh + real :: u_face ! Zonal velocity at a face [L Z-1 ~> m s-1] + real :: h_face ! Thickness at a face for transport [Z ~> m] real :: slope_lim ! The value of the slope limiter, in the range of 0 to 2 [nondim] - 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. +! 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 + + ish = LB%ish ; ieh = LB%ieh ; jsh = LB%jsh ; jeh = LB%jeh + + ! hmask coded values: 1) fully covered; 2) partly covered - no export; 3) Specified boundary condition + ! relevant u_face_mask coded values: 1) Normal interior point; 4) Specified flux BC + + do j=jsh,jeh ; do I=ish-1,ieh + if (CS%u_face_mask(I,j) == 4.) then ! The flux itself is a specified boundary condition. + uh_ice(I,j) = time_step * G%dyCu(I,j) * CS%u_flux_bdry_val(I,j) + elseif ((hmask(i,j)==1) .or. (hmask(i+1,j) == 1)) then + u_face = 0.5 * (CS%u_shelf(I,J-1) + CS%u_shelf(I,J)) + h_face = 0.0 ! This will apply when the source cell is iceless or not fully ice covered. + + if (u_face > 0) then + if (hmask(i,j) == 3) then ! This is a open boundary inflow from the west + h_face = CS%thickness_bdry_val(i,j) + elseif (hmask(i,j) == 1) then ! There can be eastward flow through this face. + if ((hmask(i-1,j) == 1) .and. (hmask(i+1,j) == 1)) then + slope_lim = slope_limiter(h0(i,j)-h0(i-1,j), h0(i+1,j)-h0(i,j)) + ! This is a 2nd-order centered scheme with a slope limiter. We could try PPM here. + h_face = h0(i,j) - slope_lim * 0.5 * (h0(i,j)-h0(i+1,j)) else - at_west_bdry=.false. + h_face = h0(i,j) endif - - if (i+i_off == G%domain%niglobal+G%domain%nihalo) then - at_east_bdry=.true. + endif + else + if (hmask(i+1,j) == 3) then ! This is a open boundary inflow from the east + h_face = CS%thickness_bdry_val(i+1,j) + elseif (hmask(i+1,j) == 1) then + if ((hmask(i,j) == 1) .and. (hmask(i+2,j) == 1)) then + slope_lim = slope_limiter(h0(i+1,j)-h0(i,j), h0(i+2,j)-h0(i+1,j)) + h_face = h0(i+1,j) - slope_lim * 0.5 * (h0(i+1,j)-h0(i,j)) else - at_east_bdry=.false. - endif - - if (hmask(i,j) == 1) then - - h_after_uflux(i,j) = h0(i,j) - - stencil(:) = h0(i-2:i+2,j) ! fine as long has nx_halo >= 2 - - flux_diff = 0 - - ! 1ST DO LEFT FACE - - if (CS%u_face_mask(I-1,j) == 4.) then - - flux_diff = flux_diff + G%dyCu(I-1,j) * time_step * CS%u_flux_bdry_val(I-1,j) / G%areaT(i,j) - - 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 = flux_diff + ABS(u_face) * G%dyCu(I-1,j) * time_step * stencil(-1) / G%areaT(i,j) - - elseif (hmask(i-1,j) * hmask(i-2,j) == 1) then ! h(i-2) and h(i-1) are valid - slope_lim = slope_limiter(stencil(-1)-stencil(-2), stencil(0)-stencil(-1)) - flux_diff = flux_diff + ABS(u_face) * G%dyCu(I-1,j)* time_step / G%areaT(i,j) * & - (stencil(-1) - slope_lim * (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 = flux_diff + ABS(u_face) * (G%dyCu(I-1,j) * time_step / G%areaT(i,j)) * 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 - slope_lim = slope_limiter(stencil(0)-stencil(1), stencil(-1)-stencil(0)) - flux_diff = flux_diff - ABS(u_face) * G%dyCu(I-1,j) * time_step / G%areaT(i,j) * & - (stencil(0) - slope_lim * (stencil(0)-stencil(-1))/2) - - else - flux_diff = flux_diff - ABS(u_face) * (G%dyCu(I-1,j) * time_step / G%areaT(i,j)) * stencil(0) - - if ((hmask(i-1,j) == 0) .OR. (hmask(i-1,j) == 2)) then - flux_enter(i-1,j,2) = ABS(u_face) * G%dyCu(I-1,j) * time_step * stencil(0) - endif - endif - endif - endif - - ! NEXT DO RIGHT FACE - - ! get u-velocity at center of east face - - if (CS%u_face_mask(I,j) == 4.) then - - flux_diff = flux_diff + G%dyCu(I,j) * time_step * CS%u_flux_bdry_val(I,j) / G%areaT(i,j) - - 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 = flux_diff + ABS(u_face) * G%dyCu(I,j) * time_step * stencil(1) / G%areaT(i,j) - - elseif (hmask(i+1,j) * hmask(i+2,j) == 1) then ! h(i+2) and h(i+1) are valid - - slope_lim = slope_limiter(stencil(1)-stencil(2), stencil(0)-stencil(1)) - flux_diff = flux_diff + ABS(u_face) * G%dyCu(I,j) * time_step / G%areaT(i,j) * & - (stencil(1) - slope_lim * (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 = flux_diff + ABS(u_face) * (G%dyCu(I,j) * time_step / G%areaT(i,j)) * 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 - - slope_lim = slope_limiter(stencil(0)-stencil(-1), stencil(1)-stencil(0)) - flux_diff = flux_diff - ABS(u_face) * G%dyCu(I,j) * time_step / G%areaT(i,j) * & - (stencil(0) - slope_lim * (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 = flux_diff - ABS(u_face) * (G%dyCu(I,j) * time_step / G%areaT(i,j)) * stencil(0) - - if ((hmask(i+1,j) == 0) .OR. (hmask(i+1,j) == 2)) then - flux_enter(i+1,j,1) = ABS(u_face) * G%dyCu(I,j) * time_step * stencil(0) - endif - - endif - - endif - - h_after_uflux(i,j) = h_after_uflux(i,j) + flux_diff - - 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%dyCu(I-1,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%dyCu(I-1,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%dyCu(I,j) * time_step * CS%thickness_bdry_val(i+1,j) - elseif (CS%u_face_mask(I,j) == 4.) then - flux_enter(i,j,2) = G%dyCu(I,j) * time_step * CS%u_flux_bdry_val(I,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 - + h_face = h0(i+1,j) endif - endif + endif - enddo ! i loop - + uh_ice(I,j) = time_step * G%dyCu(I,j) * u_face * h_face + else + uh_ice(I,j) = 0.0 endif + enddo ; enddo - enddo ! j loop + do j=jsh,jeh ; do i=ish,ieh + if (hmask(i,j) /= 3) & + h_after_uflux(i,j) = h0(i,j) + (uh_ice(I-1,j) - uh_ice(I,j)) * G%IareaT(i,j) + + ! Update the masks of cells that have gone from no ice to partial ice. + if ((hmask(i,j) == 0) .and. ((uh_ice(I-1,j) > 0.0) .or. (uh_ice(I,j) < 0.0))) hmask(i,j) = 2 + enddo ; enddo 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) +subroutine ice_shelf_advect_thickness_y(CS, G, LB, time_step, hmask, h0, h_after_vflux, vh_ice) 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. + type(loop_bounds_type), intent(in) :: LB !< Loop bounds structure. real, intent(in) :: time_step !< The time step for this update [T ~> 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 + !! 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 [Z ~> m]. + intent(in) :: h0 !< The initial ice shelf thicknesses [Z ~> m]. real, dimension(SZDI_(G),SZDJ_(G)), & intent(inout) :: h_after_vflux !< The ice shelf thicknesses after !! the meridional mass fluxes [Z ~> m]. - real, dimension(SZDI_(G),SZDJ_(G),4), & - intent(inout) :: flux_enter !< The ice volume flux into the cell - !! through the 4 cell boundaries [Z L2 ~> m3]. + real, dimension(SZDI_(G),SZDJB_(G)), & + intent(inout) :: vh_ice ! The accumulated meridional ice volume flux [Z L2 ~> 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 eastern neighbor: flux_enter(:,:,1) - ! from western neighbor: flux_enter(:,:,2) - ! from southern neighbor: flux_enter(:,:,3) - ! from northern 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 ! Thicknesses [Z ~> m]. - real :: v_face ! Pseudo-meridional velocity at a cell face, positive if out {L T-1 ~> m s-1] - real :: flux_diff + integer :: i, j + integer :: ish, ieh, jsh, jeh + real :: v_face ! Pseudo-meridional velocity at a face [L Z-1 ~> m s-1] + real :: h_face ! Thickness at a face for transport [Z ~> m] real :: slope_lim ! The value of the slope limiter, in the range of 0 to 2 [nondim] - 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 + ! hmask coded values: 1) fully covered; 2) partly covered - no export; 3) Specified boundary condition + ! relevant u_face_mask coded values: 1) Normal interior point; 4) Specified flux BC - do j=js,je + do J=jsh-1,jeh ; do i=ish,ieh + if (CS%v_face_mask(i,J) == 4.) then ! The flux itself is a specified boundary condition. + vh_ice(i,J) = time_step * G%dxCv(i,J) * CS%v_flux_bdry_val(i,J) + elseif ((hmask(i,j)==1) .or. (hmask(i,j+1) == 1)) then - if (((j+j_off) <= G%domain%njglobal+G%domain%njhalo) .AND. & - ((j+j_off) >= G%domain%njhalo+1)) then + v_face = 0.5 * (CS%v_shelf(I-1,J) + CS%v_shelf(I,J)) + h_face = 0.0 ! This will apply when the source cell is iceless or not fully ice covered. - if (j+j_off == G%domain%njhalo+1) then - at_south_bdry=.true. + if (v_face > 0) then + if (hmask(i,j) == 3) then ! This is a open boundary inflow from the south + h_face = CS%thickness_bdry_val(i,j) + elseif (hmask(i,j) == 1) then ! There can be northtward flow through this face. + if ((hmask(i,j-1) == 1) .and. (hmask(i,j+1) == 1)) then + slope_lim = slope_limiter(h0(i,j)-h0(i,j-1), h0(i,j+1)-h0(i,j)) + ! This is a 2nd-order centered scheme with a slope limiter. We could try PPM here. + h_face = h0(i,j) - slope_lim * 0.5 * (h0(i,j)-h0(i,j+1)) else - at_south_bdry=.false. + h_face = h0(i,j) endif - - if (j+j_off == G%domain%njglobal+G%domain%njhalo) then - at_north_bdry=.true. + endif + else + if (hmask(i,j+1) == 3) then ! This is a open boundary inflow from the north + h_face = CS%thickness_bdry_val(i,j+1) + elseif (hmask(i,j+1) == 1) then + if ((hmask(i,j) == 1) .and. (hmask(i,j+2) == 1)) then + slope_lim = slope_limiter(h0(i,j+1)-h0(i,j), h0(i,j+2)-h0(i,j+1)) + h_face = h0(i,j+1) - slope_lim * 0.5 * (h0(i,j+1)-h0(i,j)) else - at_north_bdry=.false. + h_face = h0(i,j+1) endif + endif + endif - if (hmask(i,j) == 1) then - 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 = 0 - - ! 1ST DO south FACE - - if (CS%v_face_mask(i,J-1) == 4.) then - - flux_diff = flux_diff + G%dxCv(i,J-1) * time_step * CS%v_flux_bdry_val(i,J-1) / G%areaT(i,j) - - 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 = flux_diff + ABS(v_face) * G%dxCv(i,J-1) * time_step * stencil(-1) / G%areaT(i,j) - - elseif (hmask(i,j-1) * hmask(i,j-2) == 1) then ! h(j-2) and h(j-1) are valid - - slope_lim = slope_limiter(stencil(-1)-stencil(-2), stencil(0)-stencil(-1)) - flux_diff = flux_diff + ABS(v_face) * G%dxCv(i,J-1) * time_step / G%areaT(i,j) * & - (stencil(-1) - slope_lim * (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 = flux_diff + ABS(v_face) * (G%dxCv(i,J-1) * time_step / G%areaT(i,j)) * 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 - slope_lim = slope_limiter(stencil(0)-stencil(1), stencil(-1)-stencil(0)) - flux_diff = flux_diff - ABS(v_face) * G%dxCv(i,J-1) * time_step / G%areaT(i,j) * & - (stencil(0) - slope_lim * (stencil(0)-stencil(-1))/2) - else - flux_diff = flux_diff - ABS(v_face) * (G%dxCv(i,J-1) * time_step / G%areaT(i,j)) * stencil(0) - - if ((hmask(i,j-1) == 0) .OR. (hmask(i,j-1) == 2)) then - flux_enter(i,j-1,4) = ABS(v_face) * G%dxCv(i,J-1) * time_step * stencil(0) - endif - - endif - - endif - - endif - - ! NEXT DO north FACE - - if (CS%v_face_mask(i,J) == 4.) then - - flux_diff = flux_diff + G%dxCv(i,J) * time_step * CS%v_flux_bdry_val(i,J) / G%areaT(i,j) - - else - - ! get v-velocity at center of north 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 = flux_diff + ABS(v_face) * G%dxCv(i,J) * time_step * stencil(1) / G%areaT(i,j) - elseif (hmask(i,j+1) * hmask(i,j+2) == 1) then ! h(j+2) and h(j+1) are valid - slope_lim = slope_limiter(stencil(1)-stencil(2), stencil(0)-stencil(1)) - flux_diff = flux_diff + ABS(v_face) * G%dxCv(i,J) * time_step / G%areaT(i,j) * & - (stencil(1) - slope_lim * (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 = flux_diff + ABS(v_face) * G%dxCv(i,J) * time_step / G%areaT(i,j) * 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 - slope_lim = slope_limiter(stencil(0)-stencil(-1), stencil(1)-stencil(0)) - flux_diff = flux_diff - ABS(v_face) * G%dxCv(i,J) * time_step / G%areaT(i,j) * & - (stencil(0) - slope_lim * (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 = flux_diff - ABS(v_face) * G%dxCv(i,J) * time_step / G%areaT(i,j) * stencil(0) - if ((hmask(i,j+1) == 0) .OR. (hmask(i,j+1) == 2)) then - flux_enter(i,j+1,3) = ABS(v_face) * G%dxCv(i,J) * time_step * stencil(0) - endif - endif - - endif - - endif - - h_after_vflux(i,j) = h_after_vflux(i,j) + flux_diff - - 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%dxCv(i,J-1) * 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%dxCv(i,J-1) * 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%dxCv(i,J) * time_step * CS%thickness_bdry_val(i,j+1) - elseif (CS%v_face_mask(i,J) == 4.) then - flux_enter(i,j,4) = G%dxCv(i,J) * time_step * CS%v_flux_bdry_val(i,J) - endif + vh_ice(i,J) = time_step * G%dxCv(i,J) * v_face * h_face + else + vh_ice(i,J) = 0.0 + endif + enddo ; enddo - 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 + do j=jsh,jeh ; do i=ish,ieh + if (hmask(i,j) /= 3) & + h_after_vflux(i,j) = h0(i,j) + (vh_ice(i,J-1) - vh_ice(i,J)) * G%IareaT(i,j) - endif - endif - enddo ! j loop - endif - enddo ! i loop + ! Update the masks of cells that have gone from no ice to partial ice. + if ((hmask(i,j) == 0) .and. ((vh_ice(i,J-1) > 0.0) .or. (vh_ice(i,J) < 0.0))) hmask(i,j) = 2 + enddo ; enddo end subroutine ice_shelf_advect_thickness_y -subroutine shelf_advance_front(CS, ISS, G, flux_enter) +subroutine shelf_advance_front(CS, ISS, G, hmask, uh_ice, vh_ice) 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 [Z L2 ~> m3]. + 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(SZDIB_(G),SZDJ_(G)), & + intent(inout) :: uh_ice ! The accumulated zonal ice volume flux [Z L2 ~> m3] + real, dimension(SZDI_(G),SZDJB_(G)), & + intent(inout) :: vh_ice ! The accumulated meridional ice volume flux [Z L2 ~> 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 @@ -1758,7 +1478,7 @@ subroutine shelf_advance_front(CS, ISS, G, flux_enter) ! 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 + ! 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 @@ -1788,7 +1508,8 @@ subroutine shelf_advance_front(CS, ISS, G, flux_enter) real :: dxdyh ! Cell area [L2 ~> m2] character(len=160) :: mesg ! The text of an error message 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 ! The ice volume flux into the + ! cell through the 4 cell boundaries [Z L2 ~> m3]. real, dimension(SZDI_(G),SZDJ_(G),4) :: flux_enter_replace ! An updated ice volume flux into the ! cell through the 4 cell boundaries [Z L2 ~> m3]. @@ -1796,6 +1517,15 @@ subroutine shelf_advance_front(CS, ISS, G, flux_enter) i_off = G%idg_offset ; j_off = G%jdg_offset iter_count = 0 ; iter_flag = 1 + flux_enter(:,:,:) = 0.0 + do j=jsc-1,jec+1 ; do i=isc-1,iec+1 + if ((hmask(i,j) == 0) .or. (hmask(i,j) == 2)) then + flux_enter(i,j,1) = max(uh_ice(I-1,j), 0.0) + flux_enter(i,j,2) = max(-uh_ice(I,j), 0.0) + flux_enter(i,j,3) = max(vh_ice(i,J-1), 0.0) + flux_enter(i,j,4) = max(-vh_ice(i,J), 0.0) + endif + enddo ; enddo mapi(1) = -1 ; mapi(2) = 1 ; mapi(3:4) = 0 mapj(3) = -1 ; mapj(4) = 1 ; mapj(1:2) = 0 @@ -2242,7 +1972,7 @@ subroutine CG_action(uret, vret, u_shlf, v_shlf, Phi, Phisub, umask, vmask, hmas intent(inout) :: vret !< The retarding stresses working at v-points [R L3 Z T-2 ~> kg m s-2]. 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 [L-1 ~> m-1]. + !! quadrature points surrounding the cell vertices [L-1 ~> m-1]. real, dimension(:,:,:,:,:,:), & intent(in) :: Phisub !< Quadrature structure weights at subgridscale !! locations for finite element calculations [nondim] @@ -2304,9 +2034,9 @@ subroutine CG_action(uret, vret, u_shlf, v_shlf, Phi, Phisub, umask, vmask, hmas real :: ux, uy, vx, vy ! Components of velocity shears or divergence [T-1 ~> s-1] real :: uq, vq ! Interpolated velocities [L T-1 ~> m s-1] - integer :: iq, jq, iphi, jphi, i, j, ilq, jlq + integer :: iq, jq, iphi, jphi, i, j, ilq, jlq, Itgt, Jtgt real, dimension(2) :: xquad - real, dimension(2,2) :: Ucell, Vcell, Hcell, Usubcontr, Vsubcontr + real, dimension(2,2) :: Ucell, Vcell, Hcell, Usub, Vsub xquad(1) = .5 * (1-sqrt(1./3)) ; xquad(2) = .5 * (1+sqrt(1./3)) @@ -2344,84 +2074,73 @@ subroutine CG_action(uret, vret, u_shlf, v_shlf, Phi, Phisub, umask, vmask, hmas v_shlf(I-1,J) * Phi(6,2*(jq-1)+iq,i,j) + & v_shlf(I,J) * Phi(8,2*(jq-1)+iq,i,j) - 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) + 0.25 * ice_visc(i,j) * & + do iphi=1,2 ; do jphi=1,2 ; Itgt = I-2+iphi ; Jtgt = J-2-jphi + if (umask(Itgt,Jtgt) == 1) uret(Itgt,Jtgt) = uret(Itgt,Jtgt) + 0.25 * ice_visc(i,j) * & ((4*ux+2*vy) * Phi(2*(2*(jphi-1)+iphi)-1,2*(jq-1)+iq,i,j) + & - (uy+vx) * Phi(2*(2*(jphi-1)+iphi),2*(jq-1)+iq,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) + 0.25 * ice_visc(i,j) * & - ((uy+vx) * Phi(2*(2*(jphi-1)+iphi)-1,2*(jq-1)+iq,i,j) + & + (uy+vx) * Phi(2*(2*(jphi-1)+iphi),2*(jq-1)+iq,i,j)) + if (vmask(Itgt,Jtgt) == 1) vret(Itgt,Jtgt) = vret(Itgt,Jtgt) + 0.25 * ice_visc(i,j) * & + ((uy+vx) * Phi(2*(2*(jphi-1)+iphi)-1,2*(jq-1)+iq,i,j) + & (4*vy+2*ux) * Phi(2*(2*(jphi-1)+iphi),2*(jq-1)+iq,i,j)) - endif if (float_cond(i,j) == 0) then ilq = 1 ; if (iq == iphi) ilq = 2 jlq = 1 ; if (jq == jphi) jlq = 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) + & - 0.25 * basal_trac(i,j) * G%areaT(i,j) * 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) + & - 0.25 * basal_trac(i,j) * G%areaT(i,j) * vq * xquad(ilq) * xquad(jlq) - endif - + if (umask(Itgt,Jtgt) == 1) uret(Itgt,Jtgt) = uret(Itgt,Jtgt) + & + 0.25 * basal_trac(i,j) * uq * xquad(ilq) * xquad(jlq) + if (vmask(Itgt,Jtgt) == 1) vret(Itgt,Jtgt) = vret(Itgt,Jtgt) + & + 0.25 * basal_trac(i,j) * vq * xquad(ilq) * xquad(jlq) endif enddo ; enddo enddo ; enddo if (float_cond(i,j) == 1) then - Usubcontr = 0.0 ; Vsubcontr = 0.0 - Ucell(:,:) = u_shlf(I-1:I,J-1:J) ; Vcell(:,:) = v_shlf(I-1:I,J-1:J) ; Hcell(:,:) = H_node(i-1:i,j-1:j) - call CG_action_subgrid_basal(Phisub, Hcell, Ucell, Vcell, G%areaT(i,j), bathyT(i,j), & - 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) * basal_trac(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) * basal_trac(i,j) - endif - enddo ; enddo + Ucell(:,:) = u_shlf(I-1:I,J-1:J) ; Vcell(:,:) = v_shlf(I-1:I,J-1:J) + Hcell(:,:) = H_node(i-1:i,j-1:j) + call CG_action_subgrid_basal(Phisub, Hcell, Ucell, Vcell, bathyT(i,j), dens_ratio, Usub, Vsub) + + if (umask(I-1,J-1)==1) uret(I-1,J-1) = uret(I-1,J-1) + Usub(1,1) * basal_trac(i,j) + if (umask(I-1,J) == 1) uret(I-1,J) = uret(I-1,J) + Usub(1,2) * basal_trac(i,j) + if (umask(I,J-1) == 1) uret(I,J-1) = uret(I,J-1) + Usub(2,1) * basal_trac(i,j) + if (umask(I,J) == 1) uret(I,J) = uret(I,J) + Usub(2,2) * basal_trac(i,j) + + if (vmask(I-1,J-1)==1) vret(I-1,J-1) = vret(I-1,J-1) + Vsub(1,1) * basal_trac(i,j) + if (vmask(I-1,J) == 1) vret(I-1,J) = vret(I-1,J) + Vsub(1,2) * basal_trac(i,j) + if (vmask(I,J-1) == 1) vret(I,J-1) = vret(I,J-1) + Vsub(2,1) * basal_trac(i,j) + if (vmask(I,J) == 1) vret(I,J) = vret(I,J) + Vsub(2,2) * basal_trac(i,j) endif endif ; enddo ; enddo end subroutine CG_action -subroutine CG_action_subgrid_basal(Phisub, H, U, V, DXDYH, bathyT, dens_ratio, Ucontr, Vcontr) +subroutine CG_action_subgrid_basal(Phisub, H, U, V, bathyT, dens_ratio, Ucontr, Vcontr) real, dimension(:,:,:,:,:,:), & intent(in) :: Phisub !< Quadrature structure weights at subgridscale !! locations for finite element calculations [nondim] real, dimension(2,2), intent(in) :: H !< The ice shelf thickness at nodal (corner) points [Z ~> m]. real, dimension(2,2), intent(in) :: U !< The zonal ice shelf velocity at vertices [L T-1 ~> m s-1] real, dimension(2,2), intent(in) :: V !< The meridional ice shelf velocity at vertices [L T-1 ~> m s-1] - real, intent(in) :: DXDYH !< The tracer cell area [L2 ~> m2] real, intent(in) :: bathyT !< The depth of ocean bathymetry at tracer points [Z ~> m]. real, intent(in) :: dens_ratio !< The density of ice divided by the density - !! of seawater [nondim] - real, dimension(2,2), intent(inout) :: Ucontr !< A field related to the subgridscale contributions to - !! the u-direction basal stress [L3 T-1 ~> m3 s-1]. - real, dimension(2,2), intent(inout) :: Vcontr !< A field related to the subgridscale contributions to - !! the v-direction basal stress [L3 T-1 ~> m3 s-1]. + !! of seawater [nondim] + real, dimension(2,2), intent(out) :: Ucontr !< The areal average of u-velocities where the ice shelf + !! is grounded, or 0 where it is floating [L T-1 ~> m s-1]. + real, dimension(2,2), intent(out) :: Vcontr !< The areal average of v-velocities where the ice shelf + !! is grounded, or 0 where it is floating [L T-1 ~> m s-1]. - real :: subarea ! A sub-cell area [L2 ~> m2] + real :: subarea ! The fractional sub-cell area [nondim] real :: hloc ! The local sub-cell ice thickness [Z ~> m] integer :: nsub, i, j, qx, qy, m, n nsub = size(Phisub,1) - subarea = DXDYH / (nsub**2) + subarea = 1.0 / (nsub**2) do n=1,2 ; do m=1,2 Ucontr(m,n) = 0.0 ; Vcontr(m,n) = 0.0 do qy=1,2 ; do qx=1,2 ; do j=1,nsub ; do i=1,nsub hloc = (Phisub(i,j,1,1,qx,qy)*H(1,1) + Phisub(i,j,2,2,qx,qy)*H(2,2)) + & (Phisub(i,j,1,2,qx,qy)*H(1,2) + Phisub(i,j,2,1,qx,qy)*H(2,1)) - if (dens_ratio * hloc - bathyT > 0) then ! if (.true.) then + if (dens_ratio * hloc - bathyT > 0) then Ucontr(m,n) = Ucontr(m,n) + subarea * 0.25 * Phisub(i,j,m,n,qx,qy) * & ((Phisub(i,j,1,1,qx,qy) * U(1,1) + Phisub(i,j,2,2,qx,qy) * U(2,2)) + & (Phisub(i,j,1,2,qx,qy) * U(1,2) + Phisub(i,j,2,1,qx,qy) * U(2,1))) @@ -2471,12 +2190,12 @@ subroutine matrix_diagonal(CS, G, US, float_cond, H_node, ice_visc, basal_trac, ! 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 :: ux, uy, vx, vy ! Interpolated weight gradients [L-1 ~> m-1] real :: uq, vq real, dimension(8,4) :: Phi ! Weight gradients [L-1 ~> m-1] real, dimension(2) :: xquad - real, dimension(2,2) :: Hcell, Usubcontr, Vsubcontr + real, dimension(2,2) :: Hcell, sub_ground + integer :: i, j, is, js, cnt, isc, jsc, iec, jec, iphi, jphi, iq, jq, ilq, jlq, Itgt, Jtgt isc = G%isc ; jsc = G%jsc ; iec = G%iec ; jec = G%jec @@ -2489,56 +2208,54 @@ subroutine matrix_diagonal(CS, G, US, float_cond, H_node, ice_visc, basal_trac, ! 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 - + do iq=1,2 ; do jq=1,2 ; do iphi=1,2 ; do jphi=1,2 ; Itgt = I-2+iphi ; Jtgt = J-2-jphi ilq = 1 ; if (iq == iphi) ilq = 2 jlq = 1 ; if (jq == jphi) jlq = 2 - if (CS%umask(I-2+iphi,J-2+jphi) == 1) then + if (CS%umask(Itgt,Jtgt) == 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) + & + u_diagonal(Itgt,Jtgt) = u_diagonal(Itgt,Jtgt) + & 0.25 * ice_visc(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)) if (float_cond(i,j) == 0) then uq = xquad(ilq) * xquad(jlq) - u_diagonal(I-2+iphi,J-2+jphi) = u_diagonal(I-2+iphi,J-2+jphi) + & - 0.25 * basal_trac(i,j) * G%areaT(i,j) * uq * xquad(ilq) * xquad(jlq) + u_diagonal(Itgt,Jtgt) = u_diagonal(Itgt,Jtgt) + & + 0.25 * basal_trac(i,j) * uq * xquad(ilq) * xquad(jlq) endif endif - if (CS%vmask(I-2+iphi,J-2+jphi) == 1) then + if (CS%vmask(Itgt,Jtgt) == 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) + & + v_diagonal(Itgt,Jtgt) = v_diagonal(Itgt,Jtgt) + & 0.25 * ice_visc(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 vq = xquad(ilq) * xquad(jlq) - v_diagonal(I-2+iphi,J-2+jphi) = v_diagonal(I-2+iphi,J-2+jphi) + & - 0.25 * basal_trac(i,j) * G%areaT(i,j) * vq * xquad(ilq) * xquad(jlq) + v_diagonal(Itgt,Jtgt) = v_diagonal(Itgt,Jtgt) + & + 0.25 * basal_trac(i,j) * vq * xquad(ilq) * xquad(jlq) endif endif enddo ; enddo ; enddo ; enddo if (float_cond(i,j) == 1) then - Usubcontr = 0.0 ; Vsubcontr = 0.0 Hcell(:,:) = H_node(i-1:i,j-1:j) - call CG_diagonal_subgrid_basal(Phisub, Hcell, G%areaT(i,j), G%bathyT(i,j), 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) * basal_trac(i,j) - v_diagonal(I-2+iphi,J-2+jphi) = v_diagonal(I-2+iphi,J-2+jphi) + Vsubcontr(iphi,jphi) * basal_trac(i,j) + call CG_diagonal_subgrid_basal(Phisub, Hcell, G%bathyT(i,j), dens_ratio, sub_ground) + do iphi=1,2 ; do jphi=1,2 ; Itgt = I-2+iphi ; Jtgt = J-2-jphi + if (CS%umask(Itgt,Jtgt) == 1) then + u_diagonal(Itgt,Jtgt) = u_diagonal(Itgt,Jtgt) + sub_ground(iphi,jphi) * basal_trac(i,j) + v_diagonal(Itgt,Jtgt) = v_diagonal(Itgt,Jtgt) + sub_ground(iphi,jphi) * basal_trac(i,j) endif enddo ; enddo endif @@ -2546,38 +2263,35 @@ subroutine matrix_diagonal(CS, G, US, float_cond, H_node, ice_visc, basal_trac, end subroutine matrix_diagonal -subroutine CG_diagonal_subgrid_basal (Phisub, H_node, DXDYH, bathyT, dens_ratio, Ucontr, Vcontr) +subroutine CG_diagonal_subgrid_basal (Phisub, H_node, bathyT, dens_ratio, sub_grnd) real, dimension(:,:,:,:,:,:), & intent(in) :: Phisub !< Quadrature structure weights at subgridscale !! locations for finite element calculations [nondim] real, dimension(2,2), intent(in) :: H_node !< The ice shelf thickness at nodal (corner) !! points [Z ~> m]. - real, intent(in) :: DXDYH !< The tracer cell area [L2 ~> m2] real, intent(in) :: bathyT !< The depth of ocean bathymetry at tracer points [Z ~> m]. real, intent(in) :: dens_ratio !< The density of ice divided by the density !! of seawater [nondim] - real, dimension(2,2), intent(inout) :: Ucontr !< A field related to the subgridscale contributions to - !! the u-direction diagonal elements from basal stress [L2 ~> m2]. - real, dimension(2,2), intent(inout) :: Vcontr !< A field related to the subgridscale contributions to - !! the v-direction diagonal elements from basal stress [L2 ~> m2]. + real, dimension(2,2), intent(out) :: sub_grnd !< The weighted fraction of the sub-cell where the ice shelf + !! is grounded [nondim] ! bathyT = cellwise-constant bed elevation - real :: subarea ! The local sub-region area [L2 ~> m2] + real :: subarea ! The fractional sub-cell area [nondim] real :: hloc ! The local sub-region thickness [Z ~> m] integer :: nsub, i, j, k, l, qx, qy, m, n nsub = size(Phisub,1) - subarea = DXDYH / (nsub**2) + subarea = 1.0 / (nsub**2) + sub_grnd(:,:) = 0.0 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,2,2,qx,qy)*H_node(2,2)) + & (Phisub(i,j,1,2,qx,qy)*H_node(1,2) + Phisub(i,j,2,1,qx,qy)*H_node(2,1)) 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 + sub_grnd(m,n) = sub_grnd(m,n) + subarea * 0.25 * Phisub(i,j,m,n,qx,qy)**2 endif enddo ; enddo ; enddo ; enddo ; enddo ; enddo @@ -2624,11 +2338,11 @@ subroutine apply_boundary_values(CS, ISS, G, US, time, Phisub, H_node, ice_visc, real, dimension(8,4) :: Phi real, dimension(2) :: xquad - integer :: i, j, isc, jsc, iec, jec, iq, jq, iphi, jphi, ilq, jlq real :: ux, uy, vx, vy ! Components of velocity shears or divergence [T-1 ~> s-1] real :: uq, vq ! Interpolated velocities [L T-1 ~> m s-1] real :: area real, dimension(2,2) :: Ucell,Vcell,Hcell,Usubcontr,Vsubcontr + integer :: i, j, isc, jsc, iec, jec, iq, jq, iphi, jphi, ilq, jlq, Itgt, Jtgt isc = G%isc ; jsc = G%jsc ; iec = G%iec ; jec = G%jec @@ -2679,50 +2393,49 @@ subroutine apply_boundary_values(CS, ISS, G, US, time, Phisub, H_node, ice_visc, 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 + do iphi=1,2 ; do jphi=1,2 ; Itgt = I-2+iphi ; Jtgt = J-2-jphi ilq = 1 ; if (iq == iphi) ilq = 2 jlq = 1 ; if (jq == jphi) jlq = 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) + & + if (CS%umask(Itgt,Jtgt) == 1) then + u_bdry_contr(Itgt,Jtgt) = u_bdry_contr(Itgt,Jtgt) + & 0.25 * ice_visc(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) + & - 0.25 * basal_trac(i,j) * G%areaT(i,j) * uq * xquad(ilq) * xquad(jlq) + u_bdry_contr(Itgt,Jtgt) = u_bdry_contr(Itgt,Jtgt) + & + 0.25 * basal_trac(i,j) * 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) + & + if (CS%vmask(Itgt,Jtgt) == 1) then + v_bdry_contr(Itgt,Jtgt) = v_bdry_contr(Itgt,Jtgt) + & 0.25 * ice_visc(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) + & - 0.25 * basal_trac(i,j) * G%areaT(i,j) * vq * xquad(ilq) * xquad(jlq) + v_bdry_contr(Itgt,Jtgt) = v_bdry_contr(Itgt,Jtgt) + & + 0.25 * basal_trac(i,j) * vq * xquad(ilq) * xquad(jlq) endif endif enddo ; enddo enddo ; enddo if (float_cond(i,j) == 1) then - Usubcontr = 0.0 ; Vsubcontr = 0.0 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, G%areaT(i,j), G%bathyT(i,j), & + call CG_action_subgrid_basal(Phisub, Hcell, Ucell, Vcell, G%bathyT(i,j), & 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) * basal_trac(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) * basal_trac(i,j) - endif - enddo ; enddo + + if (CS%umask(I-1,J-1)==1) u_bdry_contr(I-1,J-1) = u_bdry_contr(I-1,J-1) + Usubcontr(1,1) * basal_trac(i,j) + if (CS%umask(I-1,J) == 1) u_bdry_contr(I-1,J) = u_bdry_contr(I-1,J) + Usubcontr(1,2) * basal_trac(i,j) + if (CS%umask(I,J-1) == 1) u_bdry_contr(I,J-1) = u_bdry_contr(I,J-1) + Usubcontr(2,1) * basal_trac(i,j) + if (CS%umask(I,J) == 1) u_bdry_contr(I,J) = u_bdry_contr(I,J) + Usubcontr(2,2) * basal_trac(i,j) + + if (CS%vmask(I-1,J-1)==1) v_bdry_contr(I-1,J-1) = v_bdry_contr(I-1,J-1) + Vsubcontr(1,1) * basal_trac(i,j) + if (CS%vmask(I-1,J) == 1) v_bdry_contr(I-1,J) = v_bdry_contr(I-1,J) + Vsubcontr(1,2) * basal_trac(i,j) + if (CS%vmask(I,J-1) == 1) v_bdry_contr(I,J-1) = v_bdry_contr(I,J-1) + Vsubcontr(2,1) * basal_trac(i,j) + if (CS%vmask(I,J) == 1) v_bdry_contr(I,J) = v_bdry_contr(I,J) + Vsubcontr(2,2) * basal_trac(i,j) endif endif endif ; enddo ; enddo @@ -2781,7 +2494,7 @@ subroutine calc_shelf_visc(CS, ISS, G, US, u_shlf, v_shlf) umid = ((u_shlf(I,J) + u_shlf(I-1,J-1)) + (u_shlf(I,J-1) + u_shlf(I-1,J))) * 0.25 vmid = ((v_shlf(I,J) + v_shlf(I-1,J-1)) + (v_shlf(I,J-1) + v_shlf(I-1,J))) * 0.25 unorm = sqrt(umid**2 + vmid**2 + eps_min**2*(G%dxT(i,j)**2 + G%dyT(i,j)**2)) - CS%basal_traction(i,j) = CS%C_basal_friction * (US%L_T_to_m_s*unorm)**(CS%n_basal_fric-1) + CS%basal_traction(i,j) = G%areaT(i,j) * CS%C_basal_friction * (US%L_T_to_m_s*unorm)**(CS%n_basal_fric-1) endif enddo enddo @@ -2863,7 +2576,7 @@ subroutine bilinear_shape_functions (X, Y, Phi, area) real, dimension(4), intent(in) :: X !< The x-positions of the vertices of the quadrilateral [L ~> m]. real, dimension(4), intent(in) :: Y !< The y-positions of the vertices of the quadrilateral [L ~> m]. real, dimension(8,4), intent(inout) :: Phi !< The gradients of bilinear basis elements at Gaussian - !! quadrature points surrounding the cell verticies [L-1 ~> m-1]. + !! quadrature points surrounding the cell vertices [L-1 ~> m-1]. real, intent(out) :: area !< The quadrilateral cell area [L2 ~> m2]. ! X and Y must be passed in the form @@ -2932,7 +2645,7 @@ subroutine bilinear_shape_fn_grid(G, i, j, Phi) integer, intent(in) :: i !< The i-index in the grid to work on. integer, intent(in) :: j !< The j-index in the grid to work on. real, dimension(8,4), intent(inout) :: Phi !< The gradients of bilinear basis elements at Gaussian - !! quadrature points surrounding the cell verticies [L-1 ~> m-1]. + !! quadrature points surrounding the cell vertices [L-1 ~> m-1]. ! This subroutine calculates the gradients of bilinear basis elements that ! that are centered at the vertices of the cell. The values are calculated at @@ -3256,7 +2969,7 @@ end subroutine ice_shelf_dyn_end subroutine ice_shelf_temp(CS, ISS, G, US, 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 + !! the ice-shelf state type(ocean_grid_type), intent(inout) :: G !< The grid structure used by the ice shelf. type(unit_scale_type), intent(in) :: US !< A structure containing unit conversion factors real, intent(in) :: time_step !< The time step for this update [T ~> s]. @@ -3271,49 +2984,24 @@ subroutine ice_shelf_temp(CS, ISS, G, US, time_step, melt_rate, Time) ! 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 eastern neighbor: flux_enter(:,:,1) - ! from western neighbor: flux_enter(:,:,2) - ! from southern neighbor: flux_enter(:,:,3) - ! from northern 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 ! The ice volume flux into the cell - ! through the 4 cell boundaries [Z L2 ~> m3]. integer :: isd, ied, jsd, jed, i, j, isc, iec, jsc, jec - real :: t_bd, Tsurf - real :: adot ! A surface heat exchange coefficient [Z T-1 ~> m s-1]. + real :: Tsurf ! Surface air temperature. This is hard coded but should be an input argument. + real :: adot ! A surface heat exchange coefficient divided by the heat capacity of + ! ice [R Z T-1 degC-1 ~> kg m-2 s-1 degC-1]. ! For now adot and Tsurf are defined here adot=surf acc 0.1m/yr, Tsurf=-20oC, vary them later - adot = (0.1/(365.0*86400.0))*US%m_to_Z*US%T_to_s + adot = (0.1/(365.0*86400.0))*US%m_to_Z*US%T_to_s * CS%density_ice 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) @@ -3321,6 +3009,7 @@ subroutine ice_shelf_temp(CS, ISS, G, US, time_step, melt_rate, Time) enddo ; enddo do j=jsd,jed ; do i=isd,ied + ! Convert the averge temperature to a depth integrated temperature. TH(i,j) = CS%t_shelf(i,j)*ISS%h_shelf(i,j) enddo ; enddo @@ -3331,52 +3020,35 @@ subroutine ice_shelf_temp(CS, ISS, G, US, time_step, melt_rate, Time) ! 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, ISS%hmask, TH, th_after_uflux, flux_enter) - call ice_shelf_advect_temp_y(CS, G, time_step, ISS%hmask, th_after_uflux, th_after_vflux, flux_enter) + call ice_shelf_advect_temp_x(CS, G, time_step, ISS%hmask, TH, th_after_uflux) + call ice_shelf_advect_temp_y(CS, G, time_step, ISS%hmask, th_after_uflux, th_after_vflux) - do j=jsd,jed - do i=isd,ied -! if (ISS%hmask(i,j) == 1) then + do j=jsc,jec ; do i=isc,iec + ! Convert the integrated temperature back to the average temperature. +! 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) = th_after_vflux(i,j) / ISS%h_shelf(i,j) + else + CS%t_shelf(i,j) = -10.0 + endif +! endif + + 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) = th_after_vflux(i,j)/(ISS%h_shelf(i,j)) + CS%t_shelf(i,j) = CS%t_shelf(i,j) + & + time_step*(adot*Tsurf - melt_rate(i,j)*ISS%tfreeze(i,j))/(CS%density_ice*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 - 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 - !### Why is the hard-coded code uncommented and the plausible one commented out? -! CS%t_shelf(i,j) = CS%t_shelf(i,j) + & -! time_step*(adot*Tsurf - US%R_to_kg_m3*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.0/(365.0*86400.0))*US%m_to_Z*US%T_to_s)*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 + elseif (ISS%hmask(i,j) == 0) then + CS%t_shelf(i,j) = -10.0 + elseif ((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 call pass_var(CS%t_shelf, G%domain) call pass_var(CS%tmask, G%domain) @@ -3388,7 +3060,7 @@ subroutine ice_shelf_temp(CS, ISS, G, US, time_step, melt_rate, Time) end subroutine ice_shelf_temp -subroutine ice_shelf_advect_temp_x(CS, G, time_step, hmask, h0, h_after_uflux, flux_enter) +subroutine ice_shelf_advect_temp_x(CS, G, time_step, hmask, h0, h_after_uflux) 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 [T ~> s]. @@ -3400,28 +3072,10 @@ subroutine ice_shelf_advect_temp_x(CS, G, time_step, hmask, h0, h_after_uflux, f real, dimension(SZDI_(G),SZDJ_(G)), & intent(inout) :: h_after_uflux !< The ice shelf thicknesses after !! the zonal mass fluxes [Z ~> m]. - real, dimension(SZDI_(G),SZDJ_(G),4), & - intent(inout) :: flux_enter !< The integrated temperature flux into - !! the cell through the 4 cell boundaries [degC Z L2 ~> 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 eastern neighbor: flux_enter(:,:,1) - ! from western neighbor: flux_enter(:,:,2) - ! from southern neighbor: flux_enter(:,:,3) - ! from northern 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 @@ -3506,10 +3160,6 @@ subroutine ice_shelf_advect_temp_x(CS, G, time_step, hmask, h0, h_after_uflux, f else flux_diff = flux_diff - ABS(u_face) * G%dyCu(I-1,j) * time_step / G%areaT(i,j) * stencil(0) - - if ((hmask(i-1,j) == 0) .OR. (hmask(i-1,j) == 2)) then - flux_enter(i-1,j,2) = ABS(u_face) * G%dyCu(I-1,j) * time_step * stencil(0) - endif endif endif endif @@ -3555,17 +3205,10 @@ subroutine ice_shelf_advect_temp_x(CS, G, time_step, hmask, h0, h_after_uflux, f flux_diff = flux_diff - ABS(u_face) * G%dyCu(I,j) * time_step / G%areaT(i,j) * & (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 + else ! h(i+1) is valid (o.w. flux would most likely be out of cell) but h(i+2) is not flux_diff = flux_diff - ABS(u_face) * G%dyCu(I,j) * time_step / G%areaT(i,j) * stencil(0) - if ((hmask(i+1,j) == 0) .OR. (hmask(i+1,j) == 2)) then - - flux_enter(i+1,j,1) = ABS(u_face) * G%dyCu(I,j) * time_step * stencil(0) - endif - endif endif @@ -3574,37 +3217,6 @@ subroutine ice_shelf_advect_temp_x(CS, G, time_step, hmask, h0, h_after_uflux, f 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%dyCu(I-1,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%dyCu(I-1,j) * time_step * CS%u_flux_bdry_val(I-1,j)*CS%t_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%dyCu(I,j) * time_step * CS%t_bdry_val(i+1,j)* & - CS%thickness_bdry_val(i+1,j) - elseif (CS%u_face_mask(I,j) == 4.) then - flux_enter(i,j,2) = G%dyCu(I,j) * time_step * CS%u_flux_bdry_val(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 west - ! 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 west - ! is ice-covered then this cell will become partly covered -! hmask(i,j) = 2 - -! endif - endif endif @@ -3617,7 +3229,7 @@ subroutine ice_shelf_advect_temp_x(CS, G, time_step, hmask, h0, h_after_uflux, f 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) +subroutine ice_shelf_advect_temp_y(CS, G, time_step, hmask, h_after_uflux, h_after_vflux) 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 [T ~> s]. @@ -3630,28 +3242,10 @@ subroutine ice_shelf_advect_temp_y(CS, G, time_step, hmask, h_after_uflux, h_aft real, dimension(SZDI_(G),SZDJ_(G)), & intent(inout) :: h_after_vflux !< The ice shelf thicknesses after !! the meridional mass fluxes [Z ~> m]. - real, dimension(SZDI_(G),SZDJ_(G),4), & - intent(inout) :: flux_enter !< The integrated temperature flux into - !! the cell through the 4 cell boundaries [degC Z L2 ~> 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 eastern neighbor: flux_enter(:,:,1) - ! from western neighbor: flux_enter(:,:,2) - ! from southern neighbor: flux_enter(:,:,3) - ! from northern 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 @@ -3730,11 +3324,6 @@ subroutine ice_shelf_advect_temp_y(CS, G, time_step, hmask, h_after_uflux, h_aft (stencil(0) - phi * (stencil(0)-stencil(-1))/2) else flux_diff = flux_diff - ABS(v_face) * G%dxCv(i,J-1) * time_step / G%areaT(i,j) * stencil(0) - - if ((hmask(i,j-1) == 0) .OR. (hmask(i,j-1) == 2)) then - flux_enter(i,j-1,4) = ABS(v_face) * G%dxCv(i,J-1) * time_step * stencil(0) - endif - endif endif @@ -3744,7 +3333,6 @@ subroutine ice_shelf_advect_temp_y(CS, G, time_step, hmask, h_after_uflux, h_aft ! NEXT DO north FACE if (CS%v_face_mask(i,J) == 4.) then - flux_diff = flux_diff + G%dxCv(i,J) * time_step * CS%v_flux_bdry_val(i,J) *& CS%t_bdry_val(i,j+1)/ G%areaT(i,j) else @@ -3777,9 +3365,6 @@ subroutine ice_shelf_advect_temp_y(CS, G, time_step, hmask, h_after_uflux, h_aft ! (o.w. flux would most likely be out of cell) ! but h(j+2) is not flux_diff = flux_diff - ABS(v_face) * G%dxCv(i,J) * time_step / G%areaT(i,j) * stencil(0) - if ((hmask(i,j+1) == 0) .OR. (hmask(i,j+1) == 2)) then - flux_enter(i,j+1,3) = ABS(v_face) * G%dxCv(i,J) * time_step * stencil(0) - endif endif endif @@ -3787,37 +3372,6 @@ subroutine ice_shelf_advect_temp_y(CS, G, time_step, hmask, h_after_uflux, h_aft endif h_after_vflux(i,j) = h_after_vflux(i,j) + flux_diff - - 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%dxCv(i,J-1) * 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%dxCv(i,J-1) * time_step * CS%v_flux_bdry_val(i,J-1)*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%dxCv(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) == 4.) then - flux_enter(i,j,4) = G%dxCv(i,J) * time_step * CS%v_flux_bdry_val(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 west - ! 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 west is - ! ice-covered then this cell will become partly covered -! hmask(i,j) = 2 -! endif - endif endif enddo ! j loop From f2a668a4e04fc4eaa69bc04fc6ccec76eb08ae00 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 27 Mar 2020 17:55:00 -0400 Subject: [PATCH 128/316] Fixed minor syntax errors in 4 dOyxgen comments --- src/ice_shelf/MOM_ice_shelf_dynamics.F90 | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/ice_shelf/MOM_ice_shelf_dynamics.F90 b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 index f9d272b16e..ca8faf55f3 100644 --- a/src/ice_shelf/MOM_ice_shelf_dynamics.F90 +++ b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 @@ -1310,7 +1310,7 @@ subroutine ice_shelf_advect_thickness_x(CS, G, LB, time_step, hmask, h0, h_after intent(inout) :: h_after_uflux !< The ice shelf thicknesses after !! the zonal mass fluxes [Z ~> m]. real, dimension(SZDIB_(G),SZDJ_(G)), & - intent(inout) :: uh_ice ! The accumulated zonal ice volume flux [Z L2 ~> m3] + intent(inout) :: uh_ice !< The accumulated zonal ice volume flux [Z L2 ~> 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 @@ -1393,7 +1393,7 @@ subroutine ice_shelf_advect_thickness_y(CS, G, LB, time_step, hmask, h0, h_after intent(inout) :: h_after_vflux !< The ice shelf thicknesses after !! the meridional mass fluxes [Z ~> m]. real, dimension(SZDI_(G),SZDJB_(G)), & - intent(inout) :: vh_ice ! The accumulated meridional ice volume flux [Z L2 ~> m3] + intent(inout) :: vh_ice !< The accumulated meridional ice volume flux [Z L2 ~> 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 @@ -1467,9 +1467,9 @@ subroutine shelf_advance_front(CS, ISS, G, hmask, uh_ice, vh_ice) intent(inout) :: hmask !< A mask indicating which tracer points are !! partly or fully covered by an ice-shelf real, dimension(SZDIB_(G),SZDJ_(G)), & - intent(inout) :: uh_ice ! The accumulated zonal ice volume flux [Z L2 ~> m3] + intent(inout) :: uh_ice !< The accumulated zonal ice volume flux [Z L2 ~> m3] real, dimension(SZDI_(G),SZDJB_(G)), & - intent(inout) :: vh_ice ! The accumulated meridional ice volume flux [Z L2 ~> m3] + intent(inout) :: vh_ice !< The accumulated meridional ice volume flux [Z L2 ~> 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 From 7fb8f55555574a2faa5f9801beb6add833eae8bc Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Mon, 30 Mar 2020 14:48:22 -0400 Subject: [PATCH 129/316] Flipped the sign convention for wT_flux Changed the sign conventions of the internal variables wT_flux, wB_flux, dT_ustar and dS_ustar in shelf_calc_flux to follow the vertical flux sign conventions in the rest of the MOM6 code. All answers are bitwise identical. --- src/ice_shelf/MOM_ice_shelf.F90 | 32 +++++++++++++++----------------- 1 file changed, 15 insertions(+), 17 deletions(-) diff --git a/src/ice_shelf/MOM_ice_shelf.F90 b/src/ice_shelf/MOM_ice_shelf.F90 index d05631c621..6fa7aef94e 100644 --- a/src/ice_shelf/MOM_ice_shelf.F90 +++ b/src/ice_shelf/MOM_ice_shelf.F90 @@ -245,19 +245,18 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) real :: hBL_neut !< The neutral boundary layer thickness [Z ~> m]. real :: hBL_neut_h_molec !< The ratio of the neutral boundary layer thickness !! to the molecular boundary layer thickness [nondim]. - !### THESE ARE CURRENTLY POSITIVE UPWARD. - real :: wT_flux !< The upward vertical flux of heat just inside the ocean [degC Z T-1 ~> degC m s-1]. - real :: wB_flux !< The upward vertical flux of buoyancy just inside the ocean [Z2 T-3 ~> m2 s-3]. + real :: wT_flux !< The downward vertical flux of heat just inside the ocean [degC Z T-1 ~> degC m s-1]. + real :: wB_flux !< The downward vertical flux of buoyancy just inside the ocean [Z2 T-3 ~> m2 s-3]. real :: dB_dS !< The derivative of buoyancy with salinity [Z T-2 ppt-1 ~> m s-2 ppt-1]. real :: dB_dT !< The derivative of buoyancy with temperature [Z T-2 degC-1 ~> m s-2 degC-1]. real :: I_n_star ! [nondim] real :: n_star_term ! A term in the expression for nstar [T3 Z-2 ~> s3 m-2] real :: absf ! The absolute value of the Coriolis parameter [T-1 ~> s-1] real :: dIns_dwB !< The partial derivative of I_n_star with wB_flux, in [T3 Z-2 ~> s3 m-2] - real :: dT_ustar ! The difference between the ocean boundary layer temperature and the freezing - ! freezing point times the friction velocity [degC Z T-1 ~> degC m s-1] - real :: dS_ustar ! The difference between the ocean boundary layer salinity and the salinity - ! at the ice-ocean interface the friction velocity [ppt Z T-1 ~> ppt m s-1] + real :: dT_ustar ! The difference between the the freezing point and the ocean boundary layer + ! temperature times the friction velocity [degC Z T-1 ~> degC m s-1] + real :: dS_ustar ! The difference between the salinity at the ice-ocean interface and the ocean + ! boundary layer salinity times the friction velocity [ppt Z T-1 ~> ppt m s-1] real :: ustar_h ! The friction velocity in the water below the ice shelf [Z T-1 ~> m s-1] real :: Gam_turb ! [nondim] real :: Gam_mol_t, Gam_mol_s @@ -429,8 +428,8 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) ! Determine the potential temperature at the ice-ocean interface. call calculate_TFreeze(Sbdry(i,j), p_int(i), ISS%tfreeze(i,j), CS%eqn_of_state) - dT_ustar = (state%sst(i,j) - ISS%tfreeze(i,j)) * ustar_h - dS_ustar = (state%sss(i,j) - Sbdry(i,j)) * ustar_h + dT_ustar = (ISS%tfreeze(i,j) - state%sst(i,j)) * ustar_h + dS_ustar = (Sbdry(i,j) - state%sss(i,j)) * ustar_h ! First, determine the buoyancy flux assuming no effects of stability ! on the turbulence. Following H & J '99, this limit also applies @@ -449,7 +448,7 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) wT_flux = dT_ustar * I_Gam_T wB_flux = dB_dS * (dS_ustar * I_Gam_S) + dB_dT * wT_flux - if (wB_flux > 0.0) then + if (wB_flux < 0.0) then ! The buoyancy flux is stabilizing and will reduce the tubulent ! fluxes, and iteration is required. n_star_term = (ZETA_N/RC) * (hBL_neut * VK) / (ustar_h)**3 @@ -458,7 +457,7 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) ! to the neutral thickness. ! hBL = n_star*hBL_neut ; hSub = 1/8*n_star*hBL - I_n_star = sqrt(1.0 + n_star_term * wB_flux) + I_n_star = sqrt(1.0 - n_star_term * wB_flux) dIns_dwB = 0.5 * n_star_term / I_n_star if (hBL_neut_h_molec > I_n_star**2) then Gam_turb = I_VK * ((ln_neut - 2.0*log(I_n_star)) + & @@ -484,18 +483,17 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) wB_flux_new = dB_dS * (dS_ustar * I_Gam_S) + dB_dT * wT_flux ! Find the root where wB_flux_new = wB_flux. - if (abs(wB_flux_new - wB_flux) < & - 1e-4*(abs(wB_flux_new) + abs(wB_flux))) exit + if (abs(wB_flux_new - wB_flux) < 1e-4*(abs(wB_flux_new) + abs(wB_flux))) exit - dDwB_dwB_in = -dG_dwB * (dB_dS * (dS_ustar * I_Gam_S**2) + & - dB_dT * (dT_ustar * I_Gam_T**2)) - 1.0 + dDwB_dwB_in = dG_dwB * (dB_dS * (dS_ustar * I_Gam_S**2) + & + dB_dT * (dT_ustar * I_Gam_T**2)) - 1.0 ! This is Newton's method without any bounds. ! ### SHOULD BOUNDS BE NEEDED? wB_flux_new = wB_flux - (wB_flux_new - wB_flux) / dDwB_dwB_in enddo !it3 endif - ISS%tflux_ocn(i,j) = -RhoCp * wT_flux + 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 @@ -1109,7 +1107,7 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl real :: cdrag, drag_bg_vel logical :: new_sim, save_IC, var_force !This include declares and sets the variable "version". -#include "version_variable.h" +# include "version_variable.h" character(len=200) :: config character(len=200) :: IC_file,filename,inputdir character(len=40) :: mdl = "MOM_ice_shelf" ! This module's name. From 63fd8e1e85a9012ab89c09c94c6571da40113ae9 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Mon, 30 Mar 2020 17:38:25 -0400 Subject: [PATCH 130/316] +Added optional arg area to global_area_integral Added the new optional area argument to global_area_integral, to replace the area in G%areaT. All answers are bitwise identical. --- src/framework/MOM_spatial_means.F90 | 34 +++++++++++++++++++---------- 1 file changed, 22 insertions(+), 12 deletions(-) diff --git a/src/framework/MOM_spatial_means.F90 b/src/framework/MOM_spatial_means.F90 index 85d5ce452b..d4b687b0a5 100644 --- a/src/framework/MOM_spatial_means.F90 +++ b/src/framework/MOM_spatial_means.F90 @@ -47,14 +47,18 @@ function global_area_mean(var, G, scale) end function global_area_mean -!> Return the global area integral of a variable. This uses reproducing sums. -function global_area_integral(var, G, scale) - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - real, dimension(SZI_(G), SZJ_(G)), intent(in) :: var !< The variable to integrate - real, optional, intent(in) :: scale !< A rescaling factor for the variable - real, dimension(SZI_(G), SZJ_(G)) :: tmpForSumming - real :: global_area_integral - +!> Return the global area integral of a variable, by default using the masked area from the +!! grid, but an alternate could be used instead. This uses reproducing sums. +function global_area_integral(var, G, scale, area) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: var !< The variable to integrate + real, optional, intent(in) :: scale !< A rescaling factor for the variable + real, dimension(SZI_(G),SZJ_(G)), optional, intent(in) :: area !< The alternate area to use, including + !! any required masking [L2 ~> m2]. + real :: global_area_integral !< The returned area integral, usually in the units of var times [m2]. + + ! Local variables + real, dimension(SZI_(G),SZJ_(G)) :: tmpForSumming real :: scalefac ! An overall scaling factor for the areas and variable. integer :: i, j, is, ie, js, je is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec @@ -62,9 +66,15 @@ function global_area_integral(var, G, scale) scalefac = G%US%L_to_m**2 ; if (present(scale)) scalefac = G%US%L_to_m**2*scale tmpForSumming(:,:) = 0. - do j=js,je ; do i=is, ie - tmpForSumming(i,j) = var(i,j) * (scalefac * G%areaT(i,j) * G%mask2dT(i,j)) - enddo ; enddo + if (present(area)) then + do j=js,je ; do i=is,ie + tmpForSumming(i,j) = var(i,j) * (scalefac * area(i,j)) + enddo ; enddo + else + do j=js,je ; do i=is,ie + tmpForSumming(i,j) = var(i,j) * (scalefac * G%areaT(i,j) * G%mask2dT(i,j)) + enddo ; enddo + endif global_area_integral = reproducing_sum(tmpForSumming) end function global_area_integral @@ -96,7 +106,7 @@ function global_layer_mean(var, h, G, GV, scale) global_temp_scalar = reproducing_sum(tmpForSumming,sums=scalarij) global_weight_scalar = reproducing_sum(weight,sums=weightij) - do k=1, nz + do k=1,nz global_layer_mean(k) = scalarij(k) / weightij(k) enddo From 7121619b29982e37233be66141def8a85d4178c0 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Mon, 30 Mar 2020 17:55:37 -0400 Subject: [PATCH 131/316] (*)Use global_area_integral in add_shelf_flux Replaced calls to the non-reproducing routines sum_across_PES with calls to global_area_integral that uses the reproducing sums when compensating for the global mean fresh water fluxes in add_shelf_flux. This also includes rescaling the dimensions of mean_melt_flux to [R Z T-1]. This could change answers at roundoff in some cases with an interactive ice shelf and CONST_SEA_LEVEL=True, but all answers in the MOM6-examples test cases are bitwise identical. --- src/ice_shelf/MOM_ice_shelf.F90 | 44 +++++++++++++++++---------------- 1 file changed, 23 insertions(+), 21 deletions(-) diff --git a/src/ice_shelf/MOM_ice_shelf.F90 b/src/ice_shelf/MOM_ice_shelf.F90 index 6fa7aef94e..f9b397451c 100644 --- a/src/ice_shelf/MOM_ice_shelf.F90 +++ b/src/ice_shelf/MOM_ice_shelf.F90 @@ -45,7 +45,8 @@ module MOM_ice_shelf 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 MOM_coms, only : reproducing_sum, sum_across_PEs +use MOM_coms, only : reproducing_sum +use MOM_spatial_means, only : global_area_integral 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 @@ -877,20 +878,21 @@ subroutine add_shelf_flux(G, US, CS, state, fluxes) real :: Irho0 !< The inverse of the mean density times unit conversion factors that !! arise because state uses MKS units [Z2 m s2 kg-1 T-2 ~> m3 kg-1]. real :: frac_area !< The fractional area covered by the ice shelf [nondim]. - real :: shelf_mass0 !< Total ice shelf mass at previous time (Time-dt). - real :: shelf_mass1 !< Total ice shelf mass at current time (Time). real :: delta_mass_shelf!< Change in ice shelf mass over one time step [kg s-1] real :: taux2, tauy2 !< The squared surface stresses [Pa]. real :: press_ice !< The pressure of the ice shelf per unit area of ocean (not ice) [Pa]. real :: asu1, asu2 !< Ocean areas covered by ice shelves at neighboring u- real :: asv1, asv2 !< and v-points [L2 ~> m2]. real :: fraz !< refreezing rate [kg m-2 s-1] - real :: mean_melt_flux !< spatial mean melt flux [kg s-1] or [kg m-2 s-1] at various points in the code. + real :: mean_melt_flux !< Spatial mean melt flux [R Z T-1 ~> kg m-2 s-1] real :: sponge_area !< total area of sponge region [m2] real :: t0 !< The previous time (Time-dt) [s]. type(time_type) :: Time0!< The previous time (Time-dt) + real, dimension(SZDI_(G),SZDJ_(G)) :: in_sponge !< 1 where the property damping occurs, 0 otherwise [nondim] real, dimension(SZDI_(G),SZDJ_(G)) :: last_mass_shelf !< Ice shelf mass !! at at previous time (Time-dt) [R Z ~> kg m-2] + real, dimension(SZDI_(G),SZDJ_(G)) :: delta_float_mass !< The change in the floating mass between + !! the two timesteps at (Time) and (Time-dt) [R Z ~> kg m-2]. real, dimension(SZDI_(G),SZDJ_(G)) :: last_h_shelf !< Ice shelf thickness [Z ~> m] !! at at previous time (Time-dt) real, dimension(SZDI_(G),SZDJ_(G)) :: last_hmask !< Ice shelf mask @@ -994,15 +996,13 @@ subroutine add_shelf_flux(G, US, CS, state, fluxes) if (.not. associated(fluxes%vprec)) allocate(fluxes%vprec(ie,je)) 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) & - mean_melt_flux = mean_melt_flux + (ISS%water_flux(i,j)) * US%RZ_T_to_kg_m2s*US%L_to_m**2*ISS%area_shelf_h(i,j) !### 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 + US%L_to_m**2*G%areaT(i,j) + in_sponge(i,j) = 1.0 + else + in_sponge(i,j) = 0.0 endif enddo ; enddo @@ -1027,20 +1027,18 @@ subroutine add_shelf_flux(G, US, CS, state, fluxes) 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. & (ISS%area_shelf_h(i,j) > 0.0)) then - shelf_mass0 = shelf_mass0 + US%RZ_to_kg_m2*US%L_to_m**2*(last_mass_shelf(i,j) * ISS%area_shelf_h(i,j)) - shelf_mass1 = shelf_mass1 + US%RZ_to_kg_m2*US%L_to_m**2*(ISS%mass_shelf(i,j) * ISS%area_shelf_h(i,j)) + delta_float_mass(i,j) = ISS%mass_shelf(i,j) - last_mass_shelf(i,j) + else + delta_float_mass(i,j) = 0.0 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 -! write(mesg,*) 'delta_mass_shelf = ', delta_mass_shelf -! call MOM_mesg(mesg,5) + delta_mass_shelf = US%kg_m2s_to_RZ_T*(global_area_integral(delta_float_mass, G, scale=US%RZ_to_kg_m2, & + area=ISS%area_shelf_h) / CS%time_step) else! first time step delta_mass_shelf = 0.0 endif @@ -1048,18 +1046,22 @@ subroutine add_shelf_flux(G, US, CS, state, fluxes) delta_mass_shelf = 0.0 endif - 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) + sponge_area = global_area_integral(in_sponge, G) + if (sponge_area > 0.0) then + mean_melt_flux = US%kg_m2s_to_RZ_T*(global_area_integral(ISS%water_flux, G, scale=US%RZ_T_to_kg_m2s, & + area=ISS%area_shelf_h) + & + delta_mass_shelf ) / sponge_area + else + mean_melt_flux = 0.0 + endif ! 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 ! evap is negative, and vprec has units of [R Z T-1 ~> kg m-2 s-1] - fluxes%vprec(i,j) = -US%kg_m2s_to_RZ_T*mean_melt_flux * CS%density_ice / (1000.0*US%kg_m3_to_R) + fluxes%vprec(i,j) = -mean_melt_flux * CS%density_ice / (1000.0*US%kg_m3_to_R) fluxes%sens(i,j) = fluxes%vprec(i,j) * CS%Cp * CS%T0 ! [ Q R Z T-1 ~> W /m^2 ] fluxes%salt_flux(i,j) = fluxes%vprec(i,j) * CS%S0*1.0e-3 ! [kgSalt/kg R Z T-1 ~> kgSalt m-2 s-1] endif From 3c3f72167b8b8e5da306021979bfc4c2697f08ed Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Mon, 30 Mar 2020 21:45:40 -0400 Subject: [PATCH 132/316] (*+)Corrected bugs in 3-eqn ice shelf skin salinity Corrected several bugs in the 3-equation ice shelf skin salinity calculation, including renaming variables for greater clarity and using forms for the solutions to a quadratic equation that are accurate without amplifying roundoff errors. In addition, a new runtime parameter, SHELF_3EQ_GAMMA_S, is read and logged when SHELF_3EQ_GAMMA is true. This will change answers and the parameter_doc files with when a thermodynamically active ice shelf is used and SHELF_THREE_EQN is true, but all answers in the MOM6-examples test cases are bitwise identical. --- src/ice_shelf/MOM_ice_shelf.F90 | 106 +++++++++++++++++--------------- 1 file changed, 57 insertions(+), 49 deletions(-) diff --git a/src/ice_shelf/MOM_ice_shelf.F90 b/src/ice_shelf/MOM_ice_shelf.F90 index f9b397451c..a4f6169844 100644 --- a/src/ice_shelf/MOM_ice_shelf.F90 +++ b/src/ice_shelf/MOM_ice_shelf.F90 @@ -26,7 +26,7 @@ module MOM_ice_shelf 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 -use MOM_time_manager, only : time_type, time_type_to_real, real_to_time +use MOM_time_manager, only : time_type, time_type_to_real, real_to_time, operator(>), operator(-) use MOM_transcribe_grid, only : copy_dyngrid_to_MOM_grid, copy_MOM_grid_to_dyngrid use MOM_unit_scaling, only : unit_scale_type, unit_scaling_init, fix_restart_unit_scaling use MOM_variables, only : surface @@ -106,6 +106,7 @@ module MOM_ice_shelf real :: kd_molec_temp!< The molecular diffusivity of heat [Z2 T-1 ~> m2 s-1]. real :: Lat_fusion !< The latent heat of fusion [Q ~> J kg-1]. real :: Gamma_T_3EQ !< Nondimensional heat-transfer coefficient, used in the 3Eq. formulation + real :: Gamma_S_3EQ !< Nondimensional salt-transfer coefficient, used in the 3Eq. formulation !< This number should be specified by the user. real :: col_thick_melt_threshold !< if the mixed layer is below this threshold, melt rate logical :: mass_from_file !< Read the ice shelf mass from a file every dt @@ -150,14 +151,13 @@ module MOM_ice_shelf !! interface. logical :: insulator !< If true, ice shelf is a perfect insulator logical :: const_gamma !< If true, gamma_T is specified by the user. - logical :: find_salt_root !< If true, if true find Sbdry using a quadratic eq. logical :: constant_sea_level !< if true, apply an evaporative, heat and salt !! fluxes. It will avoid large increase in sea level. real :: cutoff_depth !< Depth above which melt is set to zero (>= 0) [Z ~> m]. - ! The following parameters are needed if find_salt_root = true - real :: lambda1 !< liquidus coeff. The freezing point at 0 pressure and 0 salinity [degC] - real :: lambda2 !< Partial derivative of freezing temperature with salinity [degC ppt-1] - real :: lambda3 !< Partial derivative of freezing temperature with pressure [degC Pa-1] + logical :: find_salt_root !< If true, if true find Sbdry using a quadratic eq. + real :: TFr_0_0 !< The freezing point at 0 pressure and 0 salinity [degC] + real :: dTFr_dS !< Partial derivative of freezing temperature with salinity [degC ppt-1] + real :: dTFr_dp !< Partial derivative of freezing temperature with pressure [degC Pa-1] !>@{ Diagnostic handles integer :: id_melt = -1, id_exch_vel_s = -1, id_exch_vel_t = -1, & id_tfreeze = -1, id_tfl_shelf = -1, & @@ -241,7 +241,8 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) real, dimension(SZDI_(CS%grid),SZDJ_(CS%grid)) :: & Sbdry !< Salinities in the ocean at the interface with the ice shelf [ppt]. real :: Sbdry_it - real :: Sbdry1, Sbdry2, S_a, S_b, S_c ! Variables used to find salt roots + real :: Sbdry1, Sbdry2 + real :: S_a, S_b, S_c ! Variables used to find salt roots real :: dS_it !< The interface salinity change during an iteration [ppt]. real :: hBL_neut !< The neutral boundary layer thickness [Z ~> m]. real :: hBL_neut_h_molec !< The ratio of the neutral boundary layer thickness @@ -391,26 +392,31 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) ln_neut = 0.0 ; if (hBL_neut_h_molec > 1.0) ln_neut = log(hBL_neut_h_molec) if (CS%find_salt_root) then - ! read liquidus parameters - - !### This should be CS%lamda2! - S_a = CS%lambda1 * CS%Gamma_T_3EQ * CS%Cp - ! The value of 35.0 here should be a parameter? - !### This should be (CS%lambda1 + CS%lambda3*p_int(i) - state%sst(i,j)) - S_b = CS%Gamma_T_3EQ*CS%Cp*(CS%lambda2 + CS%lambda3*p_int(i)- state%sst(i,j)) - & - CS%Lat_fusion * CS%Gamma_T_3EQ/35.0 - S_c = CS%Lat_fusion * (CS%Gamma_T_3EQ/35.0) * state%sss(i,j) - - !### Depending on the sign of S_b, one of these will be inaccurate! - ! if (S_b >= 0.0) then - Sbdry1 = (-S_b + SQRT(S_b*S_b - 4*S_a*S_c)) / (2*S_a) - ! Sbdry1 = 2*S_c / (S_b + SQRT(S_b*S_b - 4*S_a*S_c)) - Sbdry2 = (-S_b - SQRT(S_b*S_b - 4*S_a*S_c)) / (2*S_a) - ! else - ! Sbdry1 = (-S_b + SQRT(S_b*S_b - 4.*S_a*S_c)) / (2.*S_a) - ! Sbdry2 = -2.*S_c / (-S_b + SQRT(S_b*S_b - 4.*S_a*S_c)) - ! endif - Sbdry(i,j) = MAX(Sbdry1, Sbdry2) + ! Solve for the skin salinity using the linearized liquidus parameters and + ! balancing the turbulent fresh water flux in the near-boundary layer with + ! the net fresh water or salt added by melting: + ! (Cp/Lat_fusion)*Gamma_T_3Eq*(TFr_skin-T_ocn) = Gamma_S_3Eq*(S_skin-S_ocn)/S_skin + + ! S_a is always < 0.0 with a realistic expression for the freezing point. + S_a = CS%dTFr_dS * CS%Gamma_T_3EQ * CS%Cp + S_b = CS%Gamma_T_3EQ*CS%Cp*(CS%TFr_0_0 + CS%dTFr_dp*p_int(i) - state%sst(i,j)) - & + CS%Lat_fusion * CS%Gamma_S_3EQ ! S_b Can take either sign, but is usually negative. + S_c = CS%Lat_fusion * CS%Gamma_S_3EQ * state%sss(i,j) ! Always >= 0 + + if (S_c == 0.0) then ! The solution for fresh water. + Sbdry(i,j) = 0.0 + elseif (S_a < 0.0) then ! This is the usual ocean case + if (S_b < 0.0) then ! This is almost always the case + Sbdry(i,j) = 2.0*S_c / (-S_b + SQRT(S_b*S_b - 4.*S_a*S_c)) + else + Sbdry(i,j) = (S_b + SQRT(S_b*S_b - 4.*S_a*S_c)) / (-2.*S_a) + endif + elseif ((S_a == 0.0) .and. (S_b < 0.0)) then ! It should be the case that S_b < 0. + Sbdry(i,j) = -S_c / S_b + else + call MOM_error(FATAL, "Impossible conditions found in 3-equation skin salinity calculation.") + endif + ! Safety check if (Sbdry(i,j) < 0.) then write(mesg,*) 'state%sss(i,j) = ',state%sss(i,j), 'S_a, S_b, S_c', S_a, S_b, S_c @@ -439,7 +445,7 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) 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. + I_Gam_S = CS%Gamma_S_3EQ else Gam_turb = I_VK * (ln_neut + (0.5 * I_ZETA_N - 1.0)) I_Gam_T = 1.0 / (Gam_mol_t + Gam_turb) @@ -474,7 +480,7 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) 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. + I_Gam_S = CS%Gamma_S_3EQ else I_Gam_T = 1.0 / (Gam_mol_t + Gam_turb) I_Gam_S = 1.0 / (Gam_mol_s + Gam_turb) @@ -883,11 +889,10 @@ subroutine add_shelf_flux(G, US, CS, state, fluxes) real :: press_ice !< The pressure of the ice shelf per unit area of ocean (not ice) [Pa]. real :: asu1, asu2 !< Ocean areas covered by ice shelves at neighboring u- real :: asv1, asv2 !< and v-points [L2 ~> m2]. - real :: fraz !< refreezing rate [kg m-2 s-1] real :: mean_melt_flux !< Spatial mean melt flux [R Z T-1 ~> kg m-2 s-1] real :: sponge_area !< total area of sponge region [m2] - real :: t0 !< The previous time (Time-dt) [s]. - type(time_type) :: Time0!< The previous time (Time-dt) + type(time_type) :: dTime !< The time step as a time_type + type(time_type) :: Time0 !< The previous time (Time-dt) real, dimension(SZDI_(G),SZDJ_(G)) :: in_sponge !< 1 where the property damping occurs, 0 otherwise [nondim] real, dimension(SZDI_(G),SZDJ_(G)) :: last_mass_shelf !< Ice shelf mass !! at at previous time (Time-dt) [R Z ~> kg m-2] @@ -989,8 +994,7 @@ subroutine add_shelf_flux(G, US, CS, state, 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 + !### This code has problems with hard coded constants that need 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)) @@ -1008,11 +1012,11 @@ subroutine add_shelf_flux(G, US, CS, state, fluxes) ! take into account changes in mass (or thickness) when imposing ice shelf mass if (CS%override_shelf_movement .and. CS%mass_from_file) then - t0 = time_type_to_real(CS%Time) - CS%time_step + dTime = real_to_time(CS%time_step) - ! just compute changes in mass after first time step - if (t0>0.0) then - Time0 = real_to_time(t0) + ! Compute changes in mass after at least one full time step + if (CS%Time > dTime) then + Time0 = CS%Time - dTime last_hmask(:,:) = ISS%hmask(:,:) ; last_area_shelf_h(:,:) = ISS%area_shelf_h(:,:) call time_interp_external(CS%id_read_mass, Time0, last_mass_shelf) ! This should only be done if time_interp_external did an update. @@ -1058,9 +1062,9 @@ subroutine add_shelf_flux(G, US, CS, state, fluxes) ! 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 + if (in_sponge(i,j) > 0.0) then ! evap is negative, and vprec has units of [R Z T-1 ~> kg m-2 s-1] + !### Why does mean_melt_flux need to be rescaled to get vprec? fluxes%vprec(i,j) = -mean_melt_flux * CS%density_ice / (1000.0*US%kg_m3_to_R) fluxes%sens(i,j) = fluxes%vprec(i,j) * CS%Cp * CS%T0 ! [ Q R Z T-1 ~> W /m^2 ] fluxes%salt_flux(i,j) = fluxes%vprec(i,j) * CS%S0*1.0e-3 ! [kgSalt/kg R Z T-1 ~> kgSalt m-2 s-1] @@ -1073,7 +1077,7 @@ subroutine add_shelf_flux(G, US, CS, state, fluxes) call MOM_forcing_chksum("After constant sea level", fluxes, G, CS%US, haloshift=0) endif - endif !constant_sea_level + endif ! constant_sea_level end subroutine add_shelf_flux @@ -1238,9 +1242,14 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl "If true, user specifies a constant nondimensional heat-transfer coefficient "//& "(GAMMA_T_3EQ), from which the salt-transfer coefficient is then computed "//& " as GAMMA_T_3EQ/35. This is used with SHELF_THREE_EQN.", default=.false.) - if (CS%const_gamma) call get_param(param_file, mdl, "SHELF_3EQ_GAMMA_T", CS%Gamma_T_3EQ, & - "Nondimensional heat-transfer coefficient.",default=2.2E-2, & - units="nondim.", fail_if_missing=.true.) + if (CS%const_gamma) then + call get_param(param_file, mdl, "SHELF_3EQ_GAMMA_T", CS%Gamma_T_3EQ, & + "Nondimensional heat-transfer coefficient.", & + units="nondim", default=2.2e-2) + call get_param(param_file, mdl, "SHELF_3EQ_GAMMA_S", CS%Gamma_S_3EQ, & + "Nondimensional salt-transfer coefficient.", & + default=CS%Gamma_T_3EQ/35.0, units="nondim") + endif call get_param(param_file, mdl, "ICE_SHELF_MASS_FROM_FILE", & CS%mass_from_file, "Read the mass of the "//& @@ -1252,14 +1261,13 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl "is computed from a quadratic equation. Otherwise, the previous "//& "interactive method to estimate Sbdry is used.", default=.false.) if (CS%find_salt_root) then ! read liquidus coeffs. - call get_param(param_file, mdl, "TFREEZE_S0_P0", CS%lambda1, & + call get_param(param_file, mdl, "TFREEZE_S0_P0", CS%TFr_0_0, & "this is the freezing potential temperature at "//& "S=0, P=0.", units="degC", default=0.0, do_not_log=.true.) - call get_param(param_file, mdl, "DTFREEZE_DS", CS%lambda1, & !### This should be CS%lambda2! + call get_param(param_file, mdl, "DTFREEZE_DS", CS%dTFr_dS, & "this is the derivative of the freezing potential "//& - "temperature with salinity.", & - units="degC psu-1", default=-0.054, do_not_log=.true.) - call get_param(param_file, mdl, "DTFREEZE_DP", CS%lambda3, & + "temperature with salinity.", units="degC psu-1", default=-0.054, do_not_log=.true.) + call get_param(param_file, mdl, "DTFREEZE_DP", CS%dTFr_dp, & "this is the derivative of the freezing potential "//& "temperature with pressure.", & units="degC Pa-1", default=0.0, do_not_log=.true.) From 880da802441d95b4a78c11f6ad89a2cafee56b11 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Tue, 31 Mar 2020 12:04:34 -0400 Subject: [PATCH 133/316] (*+)Corrected a bug in setting ustar_shelf Corrected a bug in setting fluxes%ustar_shelf in shelf_calc_flux, that will change answers with an active ice shelf when UTIDE is nonzero. Also rescaled the units of utide in MOM_ice_shelf.F90 to [L T-1] and added a units argument to get_param calls for 5 ISOMIP or ice-shelf related variables. This commit can change answers and the parameter_doc files in some cases when a thermodynamically active ice shelf is used, but all answers in the MOM6-examples test cases are bitwise identical. --- src/ice_shelf/MOM_ice_shelf.F90 | 25 ++++++++++++------------- src/user/ISOMIP_initialization.F90 | 10 +++++----- 2 files changed, 17 insertions(+), 18 deletions(-) diff --git a/src/ice_shelf/MOM_ice_shelf.F90 b/src/ice_shelf/MOM_ice_shelf.F90 index a4f6169844..6eb82f15d5 100644 --- a/src/ice_shelf/MOM_ice_shelf.F90 +++ b/src/ice_shelf/MOM_ice_shelf.F90 @@ -87,7 +87,7 @@ module MOM_ice_shelf type(ice_shelf_dyn_CS), pointer :: dCS => NULL() !< The control structure for the ice-shelf dynamics. real, pointer, dimension(:,:) :: & - utide => NULL() !< tidal velocity [m s-1] + utide => NULL() !< An unresolved tidal velocity [L T-1 ~> m s-1] real :: ustar_bg !< A minimum value for ustar under ice shelves [Z T-1 ~> m s-1]. real :: cdrag !< drag coefficient under ice shelves [nondim]. @@ -360,13 +360,12 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) ! Iteratively determine a self-consistent set of fluxes, with the ocean ! salinity just below the ice-shelf as the variable that is being ! iterated for. - ! ### SHOULD USTAR_SHELF BE SET YET? - !### I think that CS%utide**1 should be CS%utide**2 - ! Also I think that if taux_shelf and tauy_shelf have been calculated by the + ! ### SHOULD USTAR_SHELF BE SET YET, or should it be set from taux_shelf & tauy_shelf? + ! I think that if taux_shelf and tauy_shelf have been calculated by the ! ocean stress calculation, they should be used here or later to set ustar_shelf. - RWH - fluxes%ustar_shelf(i,j) = MAX(CS%ustar_bg, US%m_to_Z*US%T_to_s * & - sqrt(CS%cdrag*((state%u(i,j)**2 + state%v(i,j)**2) + CS%utide(i,j)**1))) + fluxes%ustar_shelf(i,j) = MAX(CS%ustar_bg, US%L_TO_Z * & + sqrt(CS%cdrag*(US%m_s_to_L_T**2*(state%u(i,j)**2 + state%v(i,j)**2) + CS%utide(i,j)**2))) ustar_h = fluxes%ustar_shelf(i,j) @@ -495,7 +494,7 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) dDwB_dwB_in = dG_dwB * (dB_dS * (dS_ustar * I_Gam_S**2) + & dB_dT * (dT_ustar * I_Gam_T**2)) - 1.0 ! This is Newton's method without any bounds. - ! ### SHOULD BOUNDS BE NEEDED? + ! ### SHOULD BOUNDS BE NEEDED IN THIS NEWTONS METHOD SOLVER? wB_flux_new = wB_flux - (wB_flux_new - wB_flux) / dDwB_dwB_in enddo !it3 endif @@ -1121,7 +1120,7 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl integer :: wd_halos(2) logical :: read_TideAmp, shelf_mass_is_dynamic, debug character(len=240) :: Tideamp_file - real :: utide + real :: utide ! A tidal velocity [L T-1 ~> m s-1] if (associated(CS)) then call MOM_error(FATAL, "MOM_ice_shelf.F90, initialize_ice_shelf: "// & "called with an associated control structure.") @@ -1218,7 +1217,7 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl "(no conduction).", default=.false.) call get_param(param_file, mdl, "MELTING_CUTOFF_DEPTH", CS%cutoff_depth, & "Depth above which the melt is set to zero (it must be >= 0) "//& - "Default value won't affect the solution.", default=0.0, scale=US%m_to_Z) !###, units="m" + "Default value won't affect the solution.", units="m", default=0.0, scale=US%m_to_Z) if (CS%cutoff_depth < 0.) & call MOM_error(WARNING,"Initialize_ice_shelf: MELTING_CUTOFF_DEPTH must be >= 0.") @@ -1342,11 +1341,11 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl call get_param(param_file, mdl, "INPUTDIR", inputdir, default=".") inputdir = slasher(inputdir) TideAmp_file = trim(inputdir) // trim(TideAmp_file) - call MOM_read_data(TideAmp_file, 'tideamp', CS%utide, G%domain, timelevel=1) + call MOM_read_data(TideAmp_file, 'tideamp', CS%utide, G%domain, timelevel=1, scale=US%m_s_to_L_T) else call get_param(param_file, mdl, "UTIDE", utide, & "The constant tidal amplitude used with INT_TIDE_DISSIPATION.", & - units="m s-1", default=0.0) + units="m s-1", default=0.0 , scale=US%m_s_to_L_T) CS%utide(:,:) = utide endif @@ -1443,10 +1442,10 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl "ice sheet/shelf thickness mask" ,"none") endif - ! if (CS%active_shelf_dynamics) then !### Consider adding an ice shelf dynamics switch. + if (CS%active_shelf_dynamics) then ! 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 + 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 diff --git a/src/user/ISOMIP_initialization.F90 b/src/user/ISOMIP_initialization.F90 index 1d14ff9cc5..aa7de04dac 100644 --- a/src/user/ISOMIP_initialization.F90 +++ b/src/user/ISOMIP_initialization.F90 @@ -172,14 +172,14 @@ subroutine ISOMIP_initialize_thickness ( h, G, GV, US, param_file, tv, just_read select case ( coordinateMode(verticalCoordinate) ) case ( REGRIDDING_LAYER, REGRIDDING_RHO ) ! Initial thicknesses for isopycnal coordinates - call get_param(param_file, mdl, "ISOMIP_T_SUR",t_sur, & - 'Temperature at the surface (interface)', default=-1.9, do_not_log=just_read) + call get_param(param_file, mdl, "ISOMIP_T_SUR", t_sur, & + 'Temperature at the surface (interface)', units="degC", default=-1.9, do_not_log=just_read) call get_param(param_file, mdl, "ISOMIP_S_SUR", s_sur, & - 'Salinity at the surface (interface)', default=33.8, do_not_log=just_read) + 'Salinity at the surface (interface)', units="ppt", default=33.8, do_not_log=just_read) call get_param(param_file, mdl, "ISOMIP_T_BOT", t_bot, & - 'Temperature at the bottom (interface)', default=-1.9, do_not_log=just_read) + 'Temperature at the bottom (interface)', units="degC", default=-1.9, do_not_log=just_read) call get_param(param_file, mdl, "ISOMIP_S_BOT", s_bot,& - 'Salinity at the bottom (interface)', default=34.55, do_not_log=just_read) + 'Salinity at the bottom (interface)', units="ppt", default=34.55, do_not_log=just_read) if (just_read) return ! All run-time parameters have been read, so return. From 1a8c75aa66807801409cbe2130abd50c4f46458b Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Tue, 31 Mar 2020 20:21:08 -0400 Subject: [PATCH 134/316] (*+)Set ice shelf latent heat consistently Set the latent heat of fusion and the heat capacity of water used by the ice shelf code consistently with the rest of MOM6, including their default values. This changes answers in all cases with active ice shelf thermodynamics. Also corrected a scaling factor for Rho0 and added several new chksum calls. Also added units for 6 ISOMIP-related input variables, and reordered the calls for several ice shelf parameters to make sure they are all being set when needed. This changes the solutions and the MOM_parameter_doc files in an updated ISOMIP test case but all answers in the MOM6-examples test cases are bitwise identical. --- src/ice_shelf/MOM_ice_shelf.F90 | 68 +++++++++++-------- .../vertical/MOM_diabatic_aux.F90 | 4 +- src/user/ISOMIP_initialization.F90 | 24 +++---- 3 files changed, 54 insertions(+), 42 deletions(-) diff --git a/src/ice_shelf/MOM_ice_shelf.F90 b/src/ice_shelf/MOM_ice_shelf.F90 index 6eb82f15d5..ab3d52c6ae 100644 --- a/src/ice_shelf/MOM_ice_shelf.F90 +++ b/src/ice_shelf/MOM_ice_shelf.F90 @@ -5,6 +5,7 @@ module MOM_ice_shelf ! This file is part of MOM6. See LICENSE.md for the license. +use MOM_constants, only : hlf 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 @@ -351,7 +352,7 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) ! DNG - to allow this everywhere Hml>0.0 allows for melting under grounded cells ! propose instead to allow where Hml > [some threshold] - + !### I do not know what the Hml flag adds; consider removing it. 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 @@ -961,6 +962,10 @@ subroutine add_shelf_flux(G, US, CS, state, fluxes) enddo ; enddo endif + if (CS%debug) then + call MOM_forcing_chksum("Before adding shelf fluxes", fluxes, G, CS%US, haloshift=0) + 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 @@ -986,6 +991,12 @@ subroutine add_shelf_flux(G, US, CS, state, fluxes) fluxes%salt_flux(i,j) = frac_area * ISS%salt_flux(i,j)*CS%flux_factor endif ; enddo ; enddo + if (CS%debug) then + call hchksum(ISS%water_flux, "water_flux add shelf fluxes", G%HI, haloshift=0, scale=US%RZ_T_to_kg_m2s) + call hchksum(ISS%tflux_ocn, "tflux_ocn add shelf fluxes", G%HI, haloshift=0, scale=US%QRZ_T_to_W_m2) + call MOM_forcing_chksum("After adding shelf fluxes", fluxes, G, CS%US, haloshift=0) + endif + ! keep sea level constant by removing mass in the sponge ! region (via virtual precip, vprec). Apply additional ! salt/heat fluxes so that the resultant surface buoyancy @@ -1071,7 +1082,7 @@ subroutine add_shelf_flux(G, US, CS, state, fluxes) enddo ; enddo if (CS%debug) then - write(mesg,*) 'Mean melt flux (kg/(m^2 s)), dt = ', mean_melt_flux, CS%time_step + write(mesg,*) 'Mean melt flux (kg/(m^2 s)), dt = ', mean_melt_flux*US%RZ_T_to_kg_m2s, CS%time_step call MOM_mesg(mesg) call MOM_forcing_chksum("After constant sea level", fluxes, G, CS%US, haloshift=0) endif @@ -1177,8 +1188,6 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl isd = G%isd ; jsd = G%jsd ; ied = G%ied ; jed = G%jed Isdq = G%IsdB ; Iedq = G%IedB ; Jsdq = G%JsdB ; Jedq = G%JedB - !### This should be a run-time parameter that is read in consistently with MOM6 and SIS2. - CS%Lat_fusion = 3.34e5*US%J_kg_to_Q CS%override_shelf_movement = .false. ; CS%active_shelf_dynamics = .false. call log_version(param_file, mdl, version, "") @@ -1208,6 +1217,8 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl call get_param(param_file, mdl, "SHELF_THERMO", CS%isthermo, & "If true, use a thermodynamically interactive ice shelf.", & default=.false.) + call get_param(param_file, mdl, "LATENT_HEAT_FUSION", CS%Lat_fusion, & + "The latent heat of fusion.", units="J/kg", default=hlf, scale=US%J_kg_to_Q) call get_param(param_file, mdl, "SHELF_THREE_EQN", CS%threeeq, & "If true, use the three equation expression of "//& "consistency to calculate the fluxes at the ice-ocean "//& @@ -1223,25 +1234,36 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl call get_param(param_file, mdl, "CONST_SEA_LEVEL", CS%constant_sea_level, & "If true, apply evaporative, heat and salt fluxes in "//& - "the sponge region. This will avoid a large increase "//& + "the sponge region. This will avoid a large increase "//& "in sea level. This option is needed for some of the "//& "ISOMIP+ experiments (Ocean3 and Ocean4). "//& "IMPORTANT: it is not currently possible to do "//& "prefect restarts using this flag.", default=.false.) - call get_param(param_file, mdl, "ISOMIP_S_SUR_SPONGE", & - CS%S0, "Surface salinity in the resoring region.", & - default=33.8, do_not_log=.true.) + call get_param(param_file, mdl, "ISOMIP_S_SUR_SPONGE", CS%S0, & + "Surface salinity in the restoring region.", & + default=33.8, units='ppt', do_not_log=.true.) - call get_param(param_file, mdl, "ISOMIP_T_SUR_SPONGE", & - CS%T0, "Surface temperature in the resoring region.", & - default=-1.9, do_not_log=.true.) + call get_param(param_file, mdl, "ISOMIP_T_SUR_SPONGE", CS%T0, & + "Surface temperature in the restoring region.", & + default=-1.9, units='degC', do_not_log=.true.) call get_param(param_file, mdl, "SHELF_3EQ_GAMMA", CS%const_gamma, & "If true, user specifies a constant nondimensional heat-transfer coefficient "//& - "(GAMMA_T_3EQ), from which the salt-transfer coefficient is then computed "//& - " as GAMMA_T_3EQ/35. This is used with SHELF_THREE_EQN.", default=.false.) - if (CS%const_gamma) then + "(GAMMA_T_3EQ), from which the default salt-transfer coefficient is set "//& + "as GAMMA_T_3EQ/35. This is used with SHELF_THREE_EQN.", default=.false.) + if (CS%threeeq) then + call get_param(param_file, mdl, "SHELF_S_ROOT", CS%find_salt_root, & + "If SHELF_S_ROOT = True, salinity at the ice/ocean interface (Sbdry) "//& + "is computed from a quadratic equation. Otherwise, the previous "//& + "interactive method to estimate Sbdry is used.", default=.false.) + else + call get_param(param_file, mdl, "SHELF_2EQ_GAMMA_T", CS%gamma_t, & + "If SHELF_THREE_EQN is false, this the fixed turbulent "//& + "exchange velocity at the ice-ocean interface.", & + units="m s-1", scale=US%m_to_Z*US%T_to_s, fail_if_missing=.true.) + endif + if (CS%const_gamma .or. CS%find_salt_root) then call get_param(param_file, mdl, "SHELF_3EQ_GAMMA_T", CS%Gamma_T_3EQ, & "Nondimensional heat-transfer coefficient.", & units="nondim", default=2.2e-2) @@ -1254,11 +1276,6 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl CS%mass_from_file, "Read the mass of the "//& "ice shelf (every time step) from a file.", default=.false.) - if (CS%threeeq) & - call get_param(param_file, mdl, "SHELF_S_ROOT", CS%find_salt_root, & - "If SHELF_S_ROOT = True, salinity at the ice/ocean interface (Sbdry) "//& - "is computed from a quadratic equation. Otherwise, the previous "//& - "interactive method to estimate Sbdry is used.", default=.false.) if (CS%find_salt_root) then ! read liquidus coeffs. call get_param(param_file, mdl, "TFREEZE_S0_P0", CS%TFr_0_0, & "this is the freezing potential temperature at "//& @@ -1272,24 +1289,19 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl units="degC Pa-1", default=0.0, do_not_log=.true.) endif - if (.not.CS%threeeq) & - call get_param(param_file, mdl, "SHELF_2EQ_GAMMA_T", CS%gamma_t, & - "If SHELF_THREE_EQN is false, this the fixed turbulent "//& - "exchange velocity at the ice-ocean interface.", & - units="m s-1", scale=US%m_to_Z*US%T_to_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, scale=US%m_to_Z*US%T_to_s**2) call get_param(param_file, mdl, "C_P", CS%Cp, & - "The heat capacity of sea water.", units="J kg-1 K-1", scale=US%J_kg_to_Q, & - fail_if_missing=.true.) + "The heat capacity of sea water, approximated as a constant. "//& + "The default value is from the TEOS-10 definition of conservative temperature.", & + units="J kg-1 K-1", default=3991.86795711963, scale=US%J_kg_to_Q) call get_param(param_file, mdl, "RHO_0", CS%Rho0, & "The mean ocean density used with BOUSSINESQ true to "//& "calculate accelerations and the mass for conservation "//& "properties, or with BOUSSINSEQ false to convert some "//& "parameters from vertical units of m to kg m-2.", & - units="kg m-3", default=1035.0, scale=US%R_to_kg_m3) !### MAKE THIS A SEPARATE PARAMETER. + units="kg m-3", default=1035.0, scale=US%kg_m3_to_R) !### MAKE THIS A SEPARATE PARAMETER. call get_param(param_file, mdl, "C_P_ICE", CS%Cp_ice, & "The heat capacity of ice.", units="J kg-1 K-1", scale=US%J_kg_to_Q, & default=2.10e3) diff --git a/src/parameterizations/vertical/MOM_diabatic_aux.F90 b/src/parameterizations/vertical/MOM_diabatic_aux.F90 index 343423a221..b17f6e4323 100644 --- a/src/parameterizations/vertical/MOM_diabatic_aux.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_aux.F90 @@ -931,7 +931,7 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t real, dimension(max(nsw,1),SZI_(G),SZK_(G)) :: & opacityBand ! The opacity (inverse of the exponential absorption length) of each frequency ! band of shortwave radation in each layer [H-1 ~> m-1 or m2 kg-1] - real, dimension(maxGroundings) :: hGrounding + real, dimension(maxGroundings) :: hGrounding ! Thickness added by each grounding event [H ~> m or kg m-2] real :: Temp_in, Salin_in real :: g_Hconv2 ! A conversion factor for use in the TKE calculation ! in units of [Z3 R2 T-2 H-2 ~> kg2 m-5 s-2 or m s-2]. @@ -1380,7 +1380,7 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t do i = 1, min(numberOfGroundings, maxGroundings) call forcing_SinglePointPrint(fluxes,G,iGround(i),jGround(i),'applyBoundaryFluxesInOut (grounding)') write(mesg(1:45),'(3es15.3)') G%geoLonT( iGround(i), jGround(i) ), & - G%geoLatT( iGround(i), jGround(i)) , hGrounding(i) + G%geoLatT( iGround(i), jGround(i)), hGrounding(i)*GV%H_to_m call MOM_error(WARNING, "MOM_diabatic_driver.F90, applyBoundaryFluxesInOut(): "//& "Mass created. x,y,dh= "//trim(mesg), all_print=.true.) enddo diff --git a/src/user/ISOMIP_initialization.F90 b/src/user/ISOMIP_initialization.F90 index aa7de04dac..ba8dc1162f 100644 --- a/src/user/ISOMIP_initialization.F90 +++ b/src/user/ISOMIP_initialization.F90 @@ -173,13 +173,13 @@ subroutine ISOMIP_initialize_thickness ( h, G, GV, US, param_file, tv, just_read case ( REGRIDDING_LAYER, REGRIDDING_RHO ) ! Initial thicknesses for isopycnal coordinates call get_param(param_file, mdl, "ISOMIP_T_SUR", t_sur, & - 'Temperature at the surface (interface)', units="degC", default=-1.9, do_not_log=just_read) + "Temperature at the surface (interface)", units="degC", default=-1.9, do_not_log=just_read) call get_param(param_file, mdl, "ISOMIP_S_SUR", s_sur, & - 'Salinity at the surface (interface)', units="ppt", default=33.8, do_not_log=just_read) + "Salinity at the surface (interface)", units="ppt", default=33.8, do_not_log=just_read) call get_param(param_file, mdl, "ISOMIP_T_BOT", t_bot, & - 'Temperature at the bottom (interface)', units="degC", default=-1.9, do_not_log=just_read) + "Temperature at the bottom (interface)", units="degC", default=-1.9, do_not_log=just_read) call get_param(param_file, mdl, "ISOMIP_S_BOT", s_bot,& - 'Salinity at the bottom (interface)', units="ppt", default=34.55, do_not_log=just_read) + "Salinity at the bottom (interface)", units="ppt", default=34.55, do_not_log=just_read) if (just_read) return ! All run-time parameters have been read, so return. @@ -293,13 +293,13 @@ subroutine ISOMIP_initialize_temperature_salinity ( T, S, h, G, GV, US, param_fi call get_param(param_file, mdl, "REGRIDDING_COORDINATE_MODE", verticalCoordinate, & default=DEFAULT_COORDINATE_MODE, do_not_log=just_read) call get_param(param_file, mdl, "ISOMIP_T_SUR",t_sur, & - 'Temperature at the surface (interface)', default=-1.9, do_not_log=just_read) + "Temperature at the surface (interface)", units="degC", default=-1.9, do_not_log=just_read) call get_param(param_file, mdl, "ISOMIP_S_SUR", s_sur, & - 'Salinity at the surface (interface)', default=33.8, do_not_log=just_read) + "Salinity at the surface (interface)", units="ppt", default=33.8, do_not_log=just_read) call get_param(param_file, mdl, "ISOMIP_T_BOT", t_bot, & - 'Temperature at the bottom (interface)', default=-1.9, do_not_log=just_read) + "Temperature at the bottom (interface)", units="degC", default=-1.9, do_not_log=just_read) call get_param(param_file, mdl, "ISOMIP_S_BOT", s_bot, & - 'Salinity at the bottom (interface)', default=34.55, do_not_log=just_read) + "Salinity at the bottom (interface)", units="ppt", default=34.55, do_not_log=just_read) call calculate_density(t_sur,s_sur,0.0,rho_sur,eqn_of_state, scale=US%kg_m3_to_R) ! write(mesg,*) 'Density in the surface layer:', rho_sur @@ -481,16 +481,16 @@ subroutine ISOMIP_initialize_sponges(G, GV, US, tv, PF, use_ALE, CSp, ACSp) do_not_log=.true.) call get_param(PF, mdl, "ISOMIP_S_SUR_SPONGE", s_sur, & - 'Surface salinity in sponge layer.', default=s_ref) ! units="ppt") + "Surface salinity in sponge layer.", units="ppt", default=s_ref) ! units="ppt") call get_param(PF, mdl, "ISOMIP_S_BOT_SPONGE", s_bot, & - 'Bottom salinity in sponge layer.', default=s_ref) ! units="ppt") + "Bottom salinity in sponge layer.", units="ppt", default=s_ref) ! units="ppt") call get_param(PF, mdl, "ISOMIP_T_SUR_SPONGE", t_sur, & - 'Surface temperature in sponge layer.', default=t_ref) ! units="degC") + "Surface temperature in sponge layer.", units="degC", default=t_ref) ! units="degC") call get_param(PF, mdl, "ISOMIP_T_BOT_SPONGE", t_bot, & - 'Bottom temperature in sponge layer.', default=t_ref) ! units="degC") + "Bottom temperature in sponge layer.", units="degC", default=t_ref) ! units="degC") T(:,:,:) = 0.0 ; S(:,:,:) = 0.0 ; Idamp(:,:) = 0.0 !; RHO(:,:,:) = 0.0 From 7e7082060df9840c5023e5efebb0f25b1f28ae5d Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Tue, 31 Mar 2020 21:49:31 -0400 Subject: [PATCH 135/316] +Added units for 13 runtime parameters Added units arguments to the get_param calls for 13 runtime parameters and corrected spelling errors in the descriptions of 4 other parameters. All answers are bitwise identical, but this leads to changes in the MOM_parameter_doc files. --- .../MOM_surface_forcing_gfdl.F90 | 2 +- src/ALE/MOM_regridding.F90 | 2 +- src/core/MOM.F90 | 4 +- .../lateral/MOM_thickness_diffuse.F90 | 4 +- .../vertical/MOM_internal_tide_input.F90 | 2 +- .../vertical/MOM_kappa_shear.F90 | 4 +- .../vertical/MOM_set_diffusivity.F90 | 46 +++++++------------ .../vertical/MOM_vert_friction.F90 | 4 +- src/tracer/MOM_neutral_diffusion.F90 | 3 +- src/tracer/advection_test_tracer.F90 | 8 ++-- src/user/adjustment_initialization.F90 | 6 +-- 11 files changed, 36 insertions(+), 49 deletions(-) diff --git a/config_src/coupled_driver/MOM_surface_forcing_gfdl.F90 b/config_src/coupled_driver/MOM_surface_forcing_gfdl.F90 index 3fd9ce7888..860ba90487 100644 --- a/config_src/coupled_driver/MOM_surface_forcing_gfdl.F90 +++ b/config_src/coupled_driver/MOM_surface_forcing_gfdl.F90 @@ -1361,7 +1361,7 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS) 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 "//& "coupler. This is used for testing and should be =1.0 for any "//& - "production runs.", default=1.0) + "production runs.", units="nondim", default=1.0) if (CS%restore_salt) then call get_param(param_file, mdl, "FLUXCONST", CS%Flux_const, & diff --git a/src/ALE/MOM_regridding.F90 b/src/ALE/MOM_regridding.F90 index f73e6e304f..bc290b3f94 100644 --- a/src/ALE/MOM_regridding.F90 +++ b/src/ALE/MOM_regridding.F90 @@ -516,7 +516,7 @@ subroutine initialize_regridding(CS, GV, US, max_depth, param_file, mdl, coord_m call get_param(param_file, mdl, "REGRID_COMPRESSIBILITY_FRACTION", tmpReal, & "When interpolating potential density profiles we can add "//& "some artificial compressibility solely to make homogeneous "//& - "regions appear stratified.", default=0.) + "regions appear stratified.", units="nondim", default=0.) call set_regrid_params(CS, compress_fraction=tmpReal) endif diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index 213f81a06e..073393f9e9 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -1806,7 +1806,7 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & if (use_temperature) then call get_param(param_file, "MOM", "FRAZIL", use_frazil, & "If true, water freezes if it gets too cold, and the "//& - "the accumulated heat deficit is returned in the "//& + "accumulated heat deficit is returned in the "//& "surface state. FRAZIL is only used if "//& "ENABLE_THERMODYNAMICS is true.", default=.false.) call get_param(param_file, "MOM", "DO_GEOTHERMAL", use_geothermal, & @@ -1888,7 +1888,7 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & call get_param(param_file, "MOM", "SURFACE_2018_ANSWERS", CS%answers_2018, & "If true, use expressions for the surface properties that recover the answers "//& "from the end of 2018. Otherwise, use more appropriate expressions that differ "//& - "at roundoff for non-Boussinsq cases.", default=default_2018_answers) + "at roundoff for non-Boussinesq cases.", default=default_2018_answers) call get_param(param_file, "MOM", "SAVE_INITIAL_CONDS", save_IC, & "If true, write the initial conditions to a file given "//& diff --git a/src/parameterizations/lateral/MOM_thickness_diffuse.F90 b/src/parameterizations/lateral/MOM_thickness_diffuse.F90 index 98b56c1cc8..895418e6e4 100644 --- a/src/parameterizations/lateral/MOM_thickness_diffuse.F90 +++ b/src/parameterizations/lateral/MOM_thickness_diffuse.F90 @@ -1840,7 +1840,7 @@ subroutine thickness_diffuse_init(Time, G, GV, US, param_file, diag, CDp, CS) call get_param(param_file, mdl, "KD_SMOOTH", CS%kappa_smooth, & "A diapycnal diffusivity that is used to interpolate "//& "more sensible values of T & S into thin layers.", & - default=1.0e-6, scale=US%m_to_Z**2*US%T_to_s) + units="m2 s-1", default=1.0e-6, scale=US%m_to_Z**2*US%T_to_s) call get_param(param_file, mdl, "KHTH_USE_FGNV_STREAMFUNCTION", CS%use_FGNV_streamfn, & "If true, use the streamfunction formulation of "//& "Ferrari et al., 2010, which effectively emphasizes "//& @@ -1849,7 +1849,7 @@ subroutine thickness_diffuse_init(Time, G, GV, US, param_file, diag, CDp, CS) call get_param(param_file, mdl, "FGNV_FILTER_SCALE", CS%FGNV_scale, & "A coefficient scaling the vertical smoothing term in the "//& "Ferrari et al., 2010, streamfunction formulation.", & - default=1., do_not_log=.not.CS%use_FGNV_streamfn) + units="nondim", default=1., do_not_log=.not.CS%use_FGNV_streamfn) call get_param(param_file, mdl, "FGNV_C_MIN", CS%FGNV_c_min, & "A minium wave speed used in the Ferrari et al., 2010, "//& "streamfunction formulation.", & diff --git a/src/parameterizations/vertical/MOM_internal_tide_input.F90 b/src/parameterizations/vertical/MOM_internal_tide_input.F90 index ebd5016855..7a0f517020 100644 --- a/src/parameterizations/vertical/MOM_internal_tide_input.F90 +++ b/src/parameterizations/vertical/MOM_internal_tide_input.F90 @@ -326,7 +326,7 @@ subroutine int_tide_input_init(Time, G, GV, US, param_file, diag, CS, itide) call get_param(param_file, mdl, "KD_SMOOTH", CS%kappa_fill, & "A diapycnal diffusivity that is used to interpolate "//& "more sensible values of T & S into thin layers.", & - default=1.0e-6, scale=US%m2_s_to_Z2_T) + units="m2 s-1", default=1.0e-6, scale=US%m2_s_to_Z2_T) call get_param(param_file, mdl, "UTIDE", utide, & "The constant tidal amplitude used with INT_TIDE_DISSIPATION.", & diff --git a/src/parameterizations/vertical/MOM_kappa_shear.F90 b/src/parameterizations/vertical/MOM_kappa_shear.F90 index 77407b6da1..0cbcf235de 100644 --- a/src/parameterizations/vertical/MOM_kappa_shear.F90 +++ b/src/parameterizations/vertical/MOM_kappa_shear.F90 @@ -2096,9 +2096,9 @@ function kappa_shear_init(Time, G, GV, US, param_file, diag, CS) "be used in single-column mode!", & default=.false., debuggingParam=.true.) call get_param(param_file, mdl, "KAPPA_SHEAR_ITER_BUG", CS%dKdQ_iteration_bug, & - "If true. use an older, dimensionally inconsistent estimate of the "//& + "If true, use an older, dimensionally inconsistent estimate of the "//& "derivative of diffusivity with energy in the Newton's method iteration. "//& - "The bug causes undercorrections when dz > 1m.", default=.true.) + "The bug causes undercorrections when dz > 1 m.", default=.true.) call get_param(param_file, mdl, "KAPPA_SHEAR_ALL_LAYER_TKE_BUG", CS%all_layer_TKE_bug, & "If true, report back the latest estimate of TKE instead of the time average "//& "TKE when there is mass in all layers. Otherwise always report the time "//& diff --git a/src/parameterizations/vertical/MOM_set_diffusivity.F90 b/src/parameterizations/vertical/MOM_set_diffusivity.F90 index 3229a7bf80..3045639232 100644 --- a/src/parameterizations/vertical/MOM_set_diffusivity.F90 +++ b/src/parameterizations/vertical/MOM_set_diffusivity.F90 @@ -1930,10 +1930,9 @@ subroutine set_diffusivity_init(Time, G, GV, US, param_file, diag, CS, int_tide_ "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).", default=0.2) + "FLUX_RI_MAX*N2/(N2+OMEGA2).", units="nondim", default=0.2) call get_param(param_file, mdl, "OMEGA", CS%omega, & - "The rotation rate of the earth.", units="s-1", & - default=7.2921e-5, scale=US%T_to_s) + "The rotation rate of the earth.", units="s-1", default=7.2921e-5, scale=US%T_to_s) call get_param(param_file, mdl, "DEFAULT_2018_ANSWERS", default_2018_answers, & "This sets the default value for the various _2018_ANSWERS parameters.", & @@ -1956,8 +1955,7 @@ subroutine set_diffusivity_init(Time, G, GV, US, param_file, diag, CS, int_tide_ call get_param(param_file, mdl, "ML_RAD_EFOLD_COEFF", CS%ML_rad_efold_coeff, & "A coefficient that is used to scale the penetration "//& "depth for turbulence below the base of the mixed layer. "//& - "This is only used if ML_RADIATION is true.", units="nondim", & - default=0.2) + "This is only used if ML_RADIATION is true.", units="nondim", default=0.2) call get_param(param_file, mdl, "ML_RAD_BUG", CS%ML_rad_bug, & "If true use code with a bug that reduces the energy available "//& "in the transition layer by a factor of the inverse of the energy "//& @@ -1966,8 +1964,7 @@ subroutine set_diffusivity_init(Time, G, GV, US, param_file, diag, CS, int_tide_ "The maximum diapycnal diffusivity due to turbulence "//& "radiated from the base of the mixed layer. "//& "This is only used if ML_RADIATION is true.", & - units="m2 s-1", default=1.0e-3, & - scale=US%m2_s_to_Z2_T) + units="m2 s-1", default=1.0e-3, scale=US%m2_s_to_Z2_T) call get_param(param_file, mdl, "ML_RAD_COEFF", CS%ML_rad_coeff, & "The coefficient which scales MSTAR*USTAR^3 to obtain "//& "the energy available for mixing below the base of the "//& @@ -1976,8 +1973,7 @@ subroutine set_diffusivity_init(Time, G, GV, US, param_file, diag, CS, int_tide_ call get_param(param_file, mdl, "ML_RAD_APPLY_TKE_DECAY", CS%ML_rad_TKE_decay, & "If true, apply the same exponential decay to ML_rad as "//& "is applied to the other surface sources of TKE in the "//& - "mixed layer code. This is only used if ML_RADIATION is true.", & - default=.true.) + "mixed layer code. This is only used if ML_RADIATION is true.", default=.true.) call get_param(param_file, mdl, "MSTAR", CS%mstar, & "The ratio of the friction velocity cubed to the TKE "//& "input to the mixed layer.", "units=nondim", default=1.2) @@ -2003,9 +1999,8 @@ subroutine set_diffusivity_init(Time, G, GV, US, param_file, diag, CS, int_tide_ call get_param(param_file, mdl, "BOTTOMDRAGLAW", CS%bottomdraglaw, & "If true, the bottom stress is calculated with a drag "//& "law of the form c_drag*|u|*u. The velocity magnitude "//& - "may be an assumed value or it may be based on the "//& - "actual velocity in the bottommost HBBL, depending on "//& - "LINEAR_DRAG.", default=.true.) + "may be an assumed value or it may be based on the actual "//& + "velocity in the bottommost HBBL, depending on LINEAR_DRAG.", default=.true.) if (CS%bottomdraglaw) then call get_param(param_file, mdl, "CDRAG", CS%cdrag, & "The drag coefficient relating the magnitude of the "//& @@ -2046,8 +2041,7 @@ subroutine set_diffusivity_init(Time, G, GV, US, param_file, diag, CS, int_tide_ "If true, uses a simple estimate of Kd/TKE that will "//& "work for arbitrary vertical coordinates. If false, "//& "calculates Kd/TKE and bounds based on exact energetics "//& - "for an isopycnal layer-formulation.", & - default=.false.) + "for an isopycnal layer-formulation.", default=.false.) ! set params releted to the background mixing call bkgnd_mixing_init(Time, G, GV, US, param_file, CS%diag, CS%bkgnd_mixing_csp) @@ -2055,8 +2049,7 @@ subroutine set_diffusivity_init(Time, G, GV, US, param_file, diag, CS, int_tide_ call get_param(param_file, mdl, "KV", CS%Kv, & "The background kinematic viscosity in the interior. "//& "The molecular value, ~1e-6 m2 s-1, may be used.", & - units="m2 s-1", scale=US%m2_s_to_Z2_T, & - fail_if_missing=.true.) + units="m2 s-1", scale=US%m2_s_to_Z2_T, fail_if_missing=.true.) call get_param(param_file, mdl, "KD", CS%Kd, & "The background diapycnal diffusivity of density in the "//& @@ -2065,13 +2058,11 @@ subroutine set_diffusivity_init(Time, G, GV, US, param_file, diag, CS, int_tide_ fail_if_missing=.true.) call get_param(param_file, mdl, "KD_MIN", CS%Kd_min, & "The minimum diapycnal diffusivity.", & - units="m2 s-1", default=0.01*CS%Kd*US%Z2_T_to_m2_s, & - scale=US%m2_s_to_Z2_T) + units="m2 s-1", default=0.01*CS%Kd*US%Z2_T_to_m2_s, scale=US%m2_s_to_Z2_T) call get_param(param_file, mdl, "KD_MAX", CS%Kd_max, & "The maximum permitted increment for the diapycnal "//& - "diffusivity from TKE-based parameterizations, or a "//& - "negative value for no limit.", units="m2 s-1", default=-1.0, & - scale=US%m2_s_to_Z2_T) + "diffusivity from TKE-based parameterizations, or a negative "//& + "value for no limit.", units="m2 s-1", default=-1.0, scale=US%m2_s_to_Z2_T) if (CS%simple_TKE_to_Kd .and. CS%Kd_max<=0.) call MOM_error(FATAL, & "set_diffusivity_init: To use SIMPLE_TKE_TO_KD, KD_MAX must be set to >0.") call get_param(param_file, mdl, "KD_ADD", CS%Kd_add, & @@ -2084,15 +2075,14 @@ subroutine set_diffusivity_init(Time, G, GV, US, param_file, diag, CS, int_tide_ call get_param(param_file, mdl, "KD_SMOOTH", CS%Kd_smooth, & "A diapycnal diffusivity that is used to interpolate "//& "more sensible values of T & S into thin layers.", & - default=1.0e-6, scale=US%m_to_Z**2*US%T_to_s) + units="m2 s-1", default=1.0e-6, scale=US%m_to_Z**2*US%T_to_s) call get_param(param_file, mdl, "DEBUG", CS%debug, & "If true, write out verbose debugging data.", & default=.false., debuggingParam=.true.) call get_param(param_file, mdl, "USER_CHANGE_DIFFUSIVITY", CS%user_change_diff, & - "If true, call user-defined code to change the diffusivity.", & - default=.false.) + "If true, call user-defined code to change the diffusivity.", default=.false.) call get_param(param_file, mdl, "DISSIPATION_MIN", CS%dissip_min, & "The minimum dissipation by which to determine a lower "//& @@ -2102,8 +2092,7 @@ subroutine set_diffusivity_init(Time, G, GV, US, param_file, diag, CS, int_tide_ "The intercept when N=0 of the N-dependent expression "//& "used to set a minimum dissipation by which to determine "//& "a lower bound of Kd (a floor): A in eps_min = A + B*N.", & - units="W m-3", default=0.0, & - scale=US%kg_m3_to_R*US%m2_s_to_Z2_T*(US%T_to_s**2)) + units="W m-3", default=0.0, scale=US%kg_m3_to_R*US%m2_s_to_Z2_T*(US%T_to_s**2)) call get_param(param_file, mdl, "DISSIPATION_N1", CS%dissip_N1, & "The coefficient multiplying N, following Gargett, used to "//& "set a minimum dissipation by which to determine a lower "//& @@ -2155,9 +2144,8 @@ subroutine set_diffusivity_init(Time, G, GV, US, param_file, diag, CS, int_tide_ "Maximum salt diffusivity for salt fingering regime.", & default=1.e-4, units="m2 s-1", scale=US%m2_s_to_Z2_T) call get_param(param_file, mdl, "KV_MOLECULAR", CS%Kv_molecular, & - "Molecular viscosity for calculation of fluxes under "//& - "double-diffusive convection.", default=1.5e-6, units="m2 s-1", & - scale=US%m2_s_to_Z2_T) + "Molecular viscosity for calculation of fluxes under double-diffusive "//& + "convection.", default=1.5e-6, units="m2 s-1", scale=US%m2_s_to_Z2_T) ! The default molecular viscosity follows the CCSM4.0 and MOM4p1 defaults. CS%id_KT_extra = register_diag_field('ocean_model', 'KT_extra', diag%axesTi, Time, & diff --git a/src/parameterizations/vertical/MOM_vert_friction.F90 b/src/parameterizations/vertical/MOM_vert_friction.F90 index e3bc14955f..5a610095ce 100644 --- a/src/parameterizations/vertical/MOM_vert_friction.F90 +++ b/src/parameterizations/vertical/MOM_vert_friction.F90 @@ -1573,8 +1573,8 @@ subroutine vertvisc_init(MIS, Time, G, GV, US, param_file, diag, ADp, dirs, & default=.true.) call get_param(param_file, mdl, "VERT_FRICTION_2018_ANSWERS", CS%answers_2018, & "If true, use the order of arithmetic and expressions that recover the answers "//& - "from the end of 2018. Otherwise, use expressions that do not use an arbitary "//& - "and hard-coded maximum viscous coupling coefficient between layers.", & + "from the end of 2018. Otherwise, use expressions that do not use an arbitrary "//& + "hard-coded maximum viscous coupling coefficient between layers.", & default=default_2018_answers) call get_param(param_file, mdl, "BOTTOMDRAGLAW", CS%bottomdraglaw, & "If true, the bottom stress is calculated with a drag "//& diff --git a/src/tracer/MOM_neutral_diffusion.F90 b/src/tracer/MOM_neutral_diffusion.F90 index b3e75ccfad..7566142d0f 100644 --- a/src/tracer/MOM_neutral_diffusion.F90 +++ b/src/tracer/MOM_neutral_diffusion.F90 @@ -145,8 +145,7 @@ logical function neutral_diffusion_init(Time, G, param_file, diag, EOS, CS) call get_param(param_file, mdl, "NDIFF_REF_PRES", CS%ref_pres, & "The reference pressure (Pa) used for the derivatives of "//& "the equation of state. If negative (default), local "//& - "pressure is used.", & - default = -1.) + "pressure is used.", units="Pa", default = -1.) ! Initialize and configure remapping if ( .not.CS%continuous_reconstruction ) then call get_param(param_file, mdl, "NDIFF_BOUNDARY_EXTRAP", boundary_extrap, & diff --git a/src/tracer/advection_test_tracer.F90 b/src/tracer/advection_test_tracer.F90 index e81003c0ff..82ea38f22c 100644 --- a/src/tracer/advection_test_tracer.F90 +++ b/src/tracer/advection_test_tracer.F90 @@ -99,13 +99,13 @@ function register_advection_test_tracer(HI, GV, param_file, CS, tr_Reg, restart_ call log_version(param_file, mdl, version, "") call get_param(param_file, mdl, "ADVECTION_TEST_X_ORIGIN", CS%x_origin, & - "The x-coorindate of the center of the test-functions.", default=0.) + "The x-coordinate of the center of the test-functions.", units="same as geoLon", default=0.) call get_param(param_file, mdl, "ADVECTION_TEST_Y_ORIGIN", CS%y_origin, & - "The y-coorindate of the center of the test-functions.", default=0.) + "The y-coordinate of the center of the test-functions.", units="same as geoLat", default=0.) call get_param(param_file, mdl, "ADVECTION_TEST_X_WIDTH", CS%x_width, & - "The x-width of the test-functions.", default=0.) + "The x-width of the test-functions.", units="same as geoLon", default=0.) call get_param(param_file, mdl, "ADVECTION_TEST_Y_WIDTH", CS%y_width, & - "The y-width of the test-functions.", default=0.) + "The y-width of the test-functions.", units="same as geoLat", default=0.) call get_param(param_file, mdl, "ADVECTION_TEST_TRACER_IC_FILE", CS%tracer_IC_file, & "The name of a file from which to read the initial "//& "conditions for the tracers, or blank to initialize "//& diff --git a/src/user/adjustment_initialization.F90 b/src/user/adjustment_initialization.F90 index bb4102f215..e4816a1338 100644 --- a/src/user/adjustment_initialization.F90 +++ b/src/user/adjustment_initialization.F90 @@ -88,13 +88,13 @@ subroutine adjustment_initialize_thickness ( h, G, GV, US, param_file, just_read units="1e-3", fail_if_missing=.not.just_read, do_not_log=just_read) call get_param(param_file, mdl,"FRONT_WAVE_AMP",front_wave_amp, & "Amplitude of trans-frontal wave perturbation", & - units="same as x,y",default=0., do_not_log=just_read) + units="same as x,y", default=0., do_not_log=just_read) call get_param(param_file, mdl,"FRONT_WAVE_LENGTH",front_wave_length, & "Wave-length of trans-frontal wave perturbation", & - units="same as x,y",default=0., do_not_log=just_read) + units="same as x,y", default=0., do_not_log=just_read) call get_param(param_file, mdl,"FRONT_WAVE_ASYM",front_wave_asym, & "Amplitude of frontal asymmetric perturbation", & - default=0., do_not_log=just_read) + units="same as x,y", default=0., do_not_log=just_read) if (just_read) return ! All run-time parameters have been read, so return. From e88732c3eae3ee31a04bda1464e137651955f0e0 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 1 Apr 2020 08:32:30 -0400 Subject: [PATCH 136/316] (*)Do not use Hml>0 as an ice shelf melt filter Avoid using the criterion that Hml>0 as a filter of when ice shelf melt can occur. I am not aware of a good justification for this filter, and it seems to be an historical artefact. Removing it causes melting to start one time step earlier at the start of a run, giving apparently better answers. This changes the answers in cases with a thermodynamically active ice shelf, including an ISOMIP test case, but all answers in the MOM6-examples test suite are bitwise identical. --- src/ice_shelf/MOM_ice_shelf.F90 | 9 ++------- 1 file changed, 2 insertions(+), 7 deletions(-) diff --git a/src/ice_shelf/MOM_ice_shelf.F90 b/src/ice_shelf/MOM_ice_shelf.F90 index ab3d52c6ae..13dd8940a3 100644 --- a/src/ice_shelf/MOM_ice_shelf.F90 +++ b/src/ice_shelf/MOM_ice_shelf.F90 @@ -350,12 +350,8 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) ! but it won't make a difference otherwise. fluxes%ustar_shelf(i,j)= 0.0 - ! DNG - to allow this everywhere Hml>0.0 allows for melting under grounded cells - ! propose instead to allow where Hml > [some threshold] - !### I do not know what the Hml flag adds; consider removing it. 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 + (ISS%area_shelf_h(i,j) > 0.0) .and. CS%isthermo ) then if (CS%threeeq) then ! Iteratively determine a self-consistent set of fluxes, with the ocean @@ -602,8 +598,7 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) 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 + (ISS%area_shelf_h(i,j) > 0.0) .and. CS%isthermo) 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. From e87c66427f66dd9d944c44e35ccdf09e174f2a64 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 1 Apr 2020 08:50:23 -0400 Subject: [PATCH 137/316] (*)Removed rescaling from mean_melt_flux to vprec Removed inappropriate density ratio rescaling from the conversion of mean_melt_flux to fluxes%vprec when CONST_SEA_LEVEL is true. Both are cast as mass fluxes, not thicknesses fluxes, so this ratio is not needed. This will change answers in some regional cases with thermodynamically active ice shelves, but all answers in the MOM6-examples test suite are bitwise identical. --- src/ice_shelf/MOM_ice_shelf.F90 | 50 +++++++++++++++++---------------- 1 file changed, 26 insertions(+), 24 deletions(-) diff --git a/src/ice_shelf/MOM_ice_shelf.F90 b/src/ice_shelf/MOM_ice_shelf.F90 index 13dd8940a3..aa20a7ccb4 100644 --- a/src/ice_shelf/MOM_ice_shelf.F90 +++ b/src/ice_shelf/MOM_ice_shelf.F90 @@ -351,7 +351,7 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) fluxes%ustar_shelf(i,j)= 0.0 if ((iDens*state%ocean_mass(i,j) > CS%col_thick_melt_threshold) .and. & - (ISS%area_shelf_h(i,j) > 0.0) .and. CS%isthermo ) then + (ISS%area_shelf_h(i,j) > 0.0) .and. CS%isthermo) then if (CS%threeeq) then ! Iteratively determine a self-consistent set of fluxes, with the ocean @@ -485,13 +485,12 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) wT_flux = dT_ustar * I_Gam_T wB_flux_new = dB_dS * (dS_ustar * I_Gam_S) + dB_dT * wT_flux - ! Find the root where wB_flux_new = wB_flux. - if (abs(wB_flux_new - wB_flux) < 1e-4*(abs(wB_flux_new) + abs(wB_flux))) exit + ! Find the root where wB_flux_new = wB_flux. Make the 1.0e-4 below into a parameter? + if (abs(wB_flux_new - wB_flux) < 1.0e-4*(abs(wB_flux_new) + abs(wB_flux))) exit dDwB_dwB_in = dG_dwB * (dB_dS * (dS_ustar * I_Gam_S**2) + & dB_dT * (dT_ustar * I_Gam_T**2)) - 1.0 - ! This is Newton's method without any bounds. - ! ### SHOULD BOUNDS BE NEEDED IN THIS NEWTONS METHOD SOLVER? + ! This is Newton's method without any bounds. Should bounds be needed? wB_flux_new = wB_flux - (wB_flux_new - wB_flux) / dDwB_dwB_in enddo !it3 endif @@ -500,13 +499,12 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) 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. - - !vertical adv/diff as in H+J 1999, eqns (26) & approx from (31). - ! Q_ice = density_ice * CS%Cp_ice * K_ice * dT/dz (at interface) - !vertical adv/diff as in H+J 199, eqs (31) & (26)... - ! dT/dz ~= min( (lprec/(density_ice*K_ice))*(CS%Temp_Ice-T_freeze) , 0.0 ) - !If this approximation is not made, iterations are required... See H+J Fig 3. + ! Calculate the heat flux inside the ice shelf. + ! Vertical adv/diff as in H+J 1999, eqns (26) & approx from (31). + ! Q_ice = density_ice * CS%Cp_ice * K_ice * dT/dz (at interface) + ! vertical adv/diff as in H+J 1999, eqs (31) & (26)... + ! dT/dz ~= min( (lprec/(density_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 (ISS%tflux_ocn(i,j) >= 0.0) then ! Freezing occurs due to downward ocean heat flux, so zero iout ce heat flux. @@ -548,19 +546,17 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) if (dS_it < 0.0) then ! Sbdry is now the upper bound. if (Sb_max_set .and. (Sbdry(i,j) > Sb_max)) & - call MOM_error(FATAL,"shelf_calc_flux: Irregular iteration for Sbdry (max).") + call MOM_error(FATAL,"shelf_calc_flux: Irregular iteration for Sbdry (max).") Sb_max = Sbdry(i,j) ; dS_max = dS_it ; Sb_max_set = .true. else ! Sbdry is now the lower bound. if (Sb_min_set .and. (Sbdry(i,j) < Sb_min)) & - call MOM_error(FATAL, & - "shelf_calc_flux: Irregular iteration for Sbdry (min).") - Sb_min = Sbdry(i,j) ; dS_min = dS_it ; Sb_min_set = .true. + call MOM_error(FATAL, "shelf_calc_flux: Irregular iteration for Sbdry (min).") + Sb_min = Sbdry(i,j) ; dS_min = dS_it ; Sb_min_set = .true. 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)) + Sbdry(i,j) = Sb_min + (Sb_max-Sb_min) * (dS_min / (dS_min - dS_max)) else Sbdry(i,j) = Sbdry_it endif ! Sb_min_set @@ -569,7 +565,7 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) endif ! CS%find_salt_root enddo !it1 - ! Check for non-convergence and/or non-boundedness? + ! Check for non-convergence and/or non-boundedness? else ! In the 2-equation form, the mixed layer turbulent exchange velocity @@ -584,7 +580,9 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) ISS%water_flux(i,j) = -I_LF * ISS%tflux_ocn(i,j) Sbdry(i,j) = 0.0 endif - else !not shelf + elseif (ISS%area_shelf_h(i,j) > 0.0) then ! This is an ice-sheet, not a floating shelf. + ISS%tflux_ocn(i,j) = 0.0 + else ! There is no ice shelf or sheet here. ISS%tflux_ocn(i,j) = 0.0 endif @@ -598,7 +596,7 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) 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) then + (ISS%area_shelf_h(i,j) > 0.0) .and. (CS%isthermo)) 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. @@ -627,8 +625,13 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) write(mesg,*) "|melt| = ",fluxes%iceshelf_melt(i,j)," > 0 and ustar_shelf = 0. at i,j", i, j call MOM_error(FATAL, "shelf_calc_flux: "//trim(mesg)) endif - endif ! area_shelf_h !!!!!!!!!!!!!!!!!!!!!!!!!!!!End of safety checks !!!!!!!!!!!!!!!!!!! + elseif (ISS%area_shelf_h(i,j) > 0.0) then + ! This is grounded ice, that could be modified to melt if a geothermal heat flux were used. + haline_driving(i,j) = 0.0 + ISS%water_flux(i,j) = 0.0 + fluxes%iceshelf_melt(i,j) = 0.0 + endif ! area_shelf_h enddo ; enddo ! i- and j-loops ! mass flux [kg s-1], part of ISOMIP diags. @@ -1069,8 +1072,7 @@ subroutine add_shelf_flux(G, US, CS, state, fluxes) do j=js,je ; do i=is,ie if (in_sponge(i,j) > 0.0) then ! evap is negative, and vprec has units of [R Z T-1 ~> kg m-2 s-1] - !### Why does mean_melt_flux need to be rescaled to get vprec? - fluxes%vprec(i,j) = -mean_melt_flux * CS%density_ice / (1000.0*US%kg_m3_to_R) + fluxes%vprec(i,j) = -mean_melt_flux fluxes%sens(i,j) = fluxes%vprec(i,j) * CS%Cp * CS%T0 ! [ Q R Z T-1 ~> W /m^2 ] fluxes%salt_flux(i,j) = fluxes%vprec(i,j) * CS%S0*1.0e-3 ! [kgSalt/kg R Z T-1 ~> kgSalt m-2 s-1] endif From fcb1e92a12eedd7315448a9a8c605e9da81e0b30 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 1 Apr 2020 12:09:04 -0400 Subject: [PATCH 138/316] +Add optional arg to ice_shelf_min_thickness_calve Added a new optional argument, halo, to ice_shelf_min_thickness_calve to specify the range of indices over which to work. All answers are bitwise identical, but there is a new argument in a public interface. --- src/ice_shelf/MOM_ice_shelf_dynamics.F90 | 31 ++++++++++++++---------- 1 file changed, 18 insertions(+), 13 deletions(-) diff --git a/src/ice_shelf/MOM_ice_shelf_dynamics.F90 b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 index ca8faf55f3..be3ae1ecde 100644 --- a/src/ice_shelf/MOM_ice_shelf_dynamics.F90 +++ b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 @@ -1650,7 +1650,7 @@ subroutine shelf_advance_front(CS, ISS, G, hmask, uh_ice, vh_ice) 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) +subroutine ice_shelf_min_thickness_calve(G, h_shelf, area_shelf_h, hmask, thickness_calve, halo) 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 [Z ~> m]. real, dimension(SZDI_(G),SZDJ_(G)), intent(inout) :: area_shelf_h !< The area per cell covered by @@ -1658,20 +1658,25 @@ subroutine ice_shelf_min_thickness_calve(G, h_shelf, area_shelf_h, hmask, thickn 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 [Z ~> m]. + integer, optional, intent(in) :: halo !< The number of halo points to use. If not present, + !! work on the entire data domain. + integer :: i, j, is, ie, js, je - integer :: i,j + if (present(halo)) then + is = G%isc - halo ; ie = G%iec + halo ; js = G%jsc - halo ; je = G%jec + halo + else + is = G%isd ; ie = G%ied ; js = G%jsd ; je = G%jed + endif - 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%ground_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 + do j=js,je ; do i=is,ie +! if ((h_shelf(i,j) < CS%thickness_calve) .and. (hmask(i,j) == 1) .and. & +! (CS%ground_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 From 04d5a83dcb93dce3bc22d7ceeeddaf303d203870 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 1 Apr 2020 12:10:23 -0400 Subject: [PATCH 139/316] (*)Use a blend of ice-shelf and open water fluxes Use a blend of ice-shelf and open water fluxes when there is partial cover by an ice shelf. This will change answers in some cases with temporally evolving ice shelves, but all answers in the MOM6-examples test suite are bitwise identical. --- src/ice_shelf/MOM_ice_shelf.F90 | 74 +++++++++++++++++++-------------- 1 file changed, 42 insertions(+), 32 deletions(-) diff --git a/src/ice_shelf/MOM_ice_shelf.F90 b/src/ice_shelf/MOM_ice_shelf.F90 index aa20a7ccb4..ea9162afc5 100644 --- a/src/ice_shelf/MOM_ice_shelf.F90 +++ b/src/ice_shelf/MOM_ice_shelf.F90 @@ -881,7 +881,8 @@ subroutine add_shelf_flux(G, US, CS, state, fluxes) ! local variables real :: Irho0 !< The inverse of the mean density times unit conversion factors that !! arise because state uses MKS units [Z2 m s2 kg-1 T-2 ~> m3 kg-1]. - real :: frac_area !< The fractional area covered by the ice shelf [nondim]. + real :: frac_shelf !< The fractional area covered by the ice shelf [nondim]. + real :: frac_open !< The fractional area of the ocean that is not covered by the ice shelf [nondim]. real :: delta_mass_shelf!< Change in ice shelf mass over one time step [kg s-1] real :: taux2, tauy2 !< The squared surface stresses [Pa]. real :: press_ice !< The pressure of the ice shelf per unit area of ocean (not ice) [Pa]. @@ -956,7 +957,7 @@ subroutine add_shelf_flux(G, US, CS, state, fluxes) 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) + fluxes%frac_shelf_h(i,j) = min(1.0, ISS%area_shelf_h(i,j) * G%IareaT(i,j)) enddo ; enddo endif @@ -965,28 +966,32 @@ subroutine add_shelf_flux(G, US, CS, state, fluxes) 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 + ! Replace fluxes intercepted by the ice shelf with fluxes from the ice shelf + frac_shelf = min(1.0, ISS%area_shelf_h(i,j) * G%IareaT(i,j)) + frac_open = max(0.0, 1.0 - frac_shelf) + + if (associated(fluxes%sw)) fluxes%sw(i,j) = frac_open * fluxes%sw(i,j) + if (associated(fluxes%sw_vis_dir)) fluxes%sw_vis_dir(i,j) = frac_open * fluxes%sw_vis_dir(i,j) + if (associated(fluxes%sw_vis_dif)) fluxes%sw_vis_dif(i,j) = frac_open * fluxes%sw_vis_dif(i,j) + if (associated(fluxes%sw_nir_dir)) fluxes%sw_nir_dir(i,j) = frac_open * fluxes%sw_nir_dir(i,j) + if (associated(fluxes%sw_nir_dif)) fluxes%sw_nir_dif(i,j) = frac_open * fluxes%sw_nir_dif(i,j) + if (associated(fluxes%lw)) fluxes%lw(i,j) = frac_open * fluxes%lw(i,j) + if (associated(fluxes%latent)) fluxes%latent(i,j) = frac_open * fluxes%latent(i,j) + if (associated(fluxes%evap)) fluxes%evap(i,j) = frac_open * fluxes%evap(i,j) 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 + fluxes%lprec(i,j) = frac_shelf*ISS%water_flux(i,j)*CS%flux_factor + frac_open * fluxes%lprec(i,j) else - fluxes%lprec(i,j) = 0.0 - fluxes%evap(i,j) = frac_area*ISS%water_flux(i,j)*CS%flux_factor + fluxes%lprec(i,j) = frac_open * fluxes%lprec(i,j) + fluxes%evap(i,j) = fluxes%evap(i,j) + frac_shelf*ISS%water_flux(i,j)*CS%flux_factor endif endif if (associated(fluxes%sens)) & - fluxes%sens(i,j) = frac_area*ISS%tflux_ocn(i,j)*CS%flux_factor + fluxes%sens(i,j) = frac_shelf*ISS%tflux_ocn(i,j)*CS%flux_factor + frac_open * fluxes%sens(i,j) + ! The salt flux should be mostly from sea ice, so perhaps none should be intercepted and this should be changed. if (associated(fluxes%salt_flux)) & - fluxes%salt_flux(i,j) = frac_area * ISS%salt_flux(i,j)*CS%flux_factor + fluxes%salt_flux(i,j) = frac_shelf * ISS%salt_flux(i,j)*CS%flux_factor + frac_open * fluxes%salt_flux(i,j) endif ; enddo ; enddo if (CS%debug) then @@ -1008,16 +1013,6 @@ subroutine add_shelf_flux(G, US, CS, state, fluxes) if (.not. associated(fluxes%vprec)) allocate(fluxes%vprec(ie,je)) fluxes%salt_flux(:,:) = 0.0 ; fluxes%vprec(:,:) = 0.0 - do j=js,je ; do i=is,ie - - !### 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 - in_sponge(i,j) = 1.0 - else - in_sponge(i,j) = 0.0 - endif - enddo ; enddo - ! take into account changes in mass (or thickness) when imposing ice shelf mass if (CS%override_shelf_movement .and. CS%mass_from_file) then dTime = real_to_time(CS%time_step) @@ -1025,18 +1020,24 @@ subroutine add_shelf_flux(G, US, CS, state, fluxes) ! Compute changes in mass after at least one full time step if (CS%Time > dTime) then Time0 = CS%Time - dTime - last_hmask(:,:) = ISS%hmask(:,:) ; last_area_shelf_h(:,:) = ISS%area_shelf_h(:,:) + do j=js,je ; do i=is,ie + last_hmask(i,j) = ISS%hmask(i,j) ; last_area_shelf_h(i,j) = ISS%area_shelf_h(i,j) + enddo ; enddo call time_interp_external(CS%id_read_mass, Time0, last_mass_shelf) + do j=js,je ; do i=is,ie ! This should only be done if time_interp_external did an update. - last_mass_shelf(:,:) = US%kg_m3_to_R*US%m_to_Z * last_mass_shelf(:,:) ! Rescale after time_interp - last_h_shelf(:,:) = last_mass_shelf(:,:) / CS%density_ice + last_mass_shelf(i,j) = US%kg_m3_to_R*US%m_to_Z * last_mass_shelf(i,j) ! Rescale after time_interp + last_h_shelf(i,j) = last_mass_shelf(i,j) / CS%density_ice + enddo ; enddo ! 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) + CS%min_thickness_simple_calve, halo=0) ! convert to mass again - last_mass_shelf(:,:) = last_h_shelf(:,:) * CS%density_ice + do j=js,je ; do i=is,ie + last_mass_shelf(i,j) = last_h_shelf(i,j) * CS%density_ice + enddo ; enddo endif ! get total ice shelf mass at (Time-dt) and (Time), in kg @@ -1059,6 +1060,15 @@ subroutine add_shelf_flux(G, US, CS, state, fluxes) endif ! average total melt flux over sponge area + do j=js,je ; do i=is,ie + !### 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 + in_sponge(i,j) = 1.0 + else + in_sponge(i,j) = 0.0 + endif + enddo ; enddo + sponge_area = global_area_integral(in_sponge, G) if (sponge_area > 0.0) then mean_melt_flux = US%kg_m2s_to_RZ_T*(global_area_integral(ISS%water_flux, G, scale=US%RZ_T_to_kg_m2s, & @@ -1754,7 +1764,7 @@ subroutine update_shelf_mass(G, US, CS, ISS, Time) 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) + CS%min_thickness_simple_calve, halo=0) endif call pass_var(ISS%area_shelf_h, G%domain) From 684681b2b34403b7b293767beba7504ab7184ffe Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 1 Apr 2020 14:58:18 -0400 Subject: [PATCH 140/316] +Ice shelf code cleanup Added a new run-time parameter to specify how much water has to be under an ice shelf for it to float; this is only logged when the CONST_SEA_LEVEL option is true. The description of another parameter is corrected, which changes the MOM_parameter_doc files with ice shelf thermodynamics. In addition, merged the mass_shelf into the same loop as h_shelf in change_thickness_using_melt and reduced the loop extents for setting forces%p_surf. Use column masses instead of thicknesses for thresholds in MOM_ice_shelf. Also combined CS%Rho0 and CS%density_ocean_avg as CS%Rho_ocn in ice_shelf_CS. All answers are bitwise identical, but there are changes in output files in some cases. --- src/ice_shelf/MOM_ice_shelf.F90 | 73 ++++++++++++++++----------------- 1 file changed, 35 insertions(+), 38 deletions(-) diff --git a/src/ice_shelf/MOM_ice_shelf.F90 b/src/ice_shelf/MOM_ice_shelf.F90 index ea9162afc5..cd9903bc82 100644 --- a/src/ice_shelf/MOM_ice_shelf.F90 +++ b/src/ice_shelf/MOM_ice_shelf.F90 @@ -94,7 +94,7 @@ module MOM_ice_shelf real :: cdrag !< drag coefficient under ice shelves [nondim]. real :: g_Earth !< The gravitational acceleration [Z T-2 ~> m s-2] real :: Cp !< The heat capacity of sea water [Q degC-1 ~> J kg-1 degC-1]. - real :: Rho0 !< A reference ocean density [R ~> kg m-3]. + real :: Rho_ocn !< A reference ocean density [R ~> kg m-3]. real :: Cp_ice !< The heat capacity of fresh ice [Q degC-1 ~> J kg-1 degC-1]. real :: gamma_t !< The (fixed) turbulent exchange velocity in the !< 2-equation formulation [Z T-1 ~> m s-1]. @@ -109,7 +109,8 @@ module MOM_ice_shelf real :: Gamma_T_3EQ !< Nondimensional heat-transfer coefficient, used in the 3Eq. formulation real :: Gamma_S_3EQ !< Nondimensional salt-transfer coefficient, used in the 3Eq. formulation !< This number should be specified by the user. - real :: col_thick_melt_threshold !< if the mixed layer is below this threshold, melt rate + real :: col_mass_melt_threshold !< An ocean column mass below the iceshelf below which melting + !! does not occur [kg m-2] logical :: mass_from_file !< Read the ice shelf mass from a file every dt !!!! PHYSICAL AND NUMERICAL PARAMETERS FOR ICE DYNAMICS !!!!!! @@ -127,10 +128,6 @@ module MOM_ice_shelf !!determined by ocean column thickness means update_OD_ffrac !! will be called (note: GL_regularize and GL_couple !! should be exclusive) - 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) logical :: calve_to_mask !< If true, calve any ice that passes outside of a masked area real :: min_thickness_simple_calve !< min. ice shelf thickness criteria for calving [Z ~> m]. real :: T0 !< temperature at ocean surface in the restoring region [degC] @@ -154,6 +151,9 @@ module MOM_ice_shelf logical :: const_gamma !< If true, gamma_T is specified by the user. logical :: constant_sea_level !< if true, apply an evaporative, heat and salt !! fluxes. It will avoid large increase in sea level. + real :: min_ocean_mass_float !< The minimum ocean mass per unit area before the ice + !! shelf is considered to float when constant_sea_level + !! is used [kg m-2] real :: cutoff_depth !< Depth above which melt is set to zero (>= 0) [Z ~> m]. logical :: find_salt_root !< If true, if true find Sbdry using a quadratic eq. real :: TFr_0_0 !< The freezing point at 0 pressure and 0 salinity [degC] @@ -270,7 +270,7 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) real :: dS_min, dS_max ! Variables used in iterating for wB_flux. real :: wB_flux_new, dDwB_dwB_in - real :: I_Gam_T, I_Gam_S, iDens + real :: I_Gam_T, I_Gam_S real :: dG_dwB ! The derivative of Gam_turb with wB [T3 Z-2 ~> s3 m-2] real :: Isqrt2 logical :: Sb_min_set, Sb_max_set @@ -296,15 +296,13 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) SC = CS%kv_molec/CS%kd_molec_salt PR = CS%kv_molec/CS%kd_molec_temp I_VK = 1.0/VK - RhoCp = CS%Rho0 * CS%Cp + RhoCp = CS%Rho_ocn * CS%Cp Isqrt2 = 1.0/sqrt(2.0) !first calculate molecular component Gam_mol_t = 12.5 * (PR**c2_3) - 6 Gam_mol_s = 12.5 * (SC**c2_3) - 6 - iDens = 1.0/CS%density_ocean_avg - ! GMM, zero some fields of the ice shelf structure (ice_shelf_CS) ! these fields are already set to zero during initialization ! However, they seem to be changed somewhere and, for diagnostic @@ -350,7 +348,7 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) ! but it won't make a difference otherwise. fluxes%ustar_shelf(i,j)= 0.0 - if ((iDens*state%ocean_mass(i,j) > CS%col_thick_melt_threshold) .and. & + if ((state%ocean_mass(i,j) > CS%col_mass_melt_threshold) .and. & (ISS%area_shelf_h(i,j) > 0.0) .and. CS%isthermo) then if (CS%threeeq) then @@ -370,7 +368,7 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) ! if (allocated(state%taux_shelf) .and. allocated(state%tauy_shelf)) then ! ! These arrays are supposed to be stress components at C-grid points, which is ! ! inconsistent with what is coded up here. - ! state%taux_shelf(i,j) = US%RZ_T_to_kg_m2s*US%Z_to_m*US%s_to_T * ustar_h**2 * CS%Rho0*Isqrt2 + ! state%taux_shelf(i,j) = US%RZ_T_to_kg_m2s*US%Z_to_m*US%s_to_T * ustar_h**2 * CS%Rho_ocn*Isqrt2 ! state%tauy_shelf(i,j) = state%taux_shelf(i,j) ! endif @@ -537,7 +535,7 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) exit ! no need to do interaction, so exit loop else - mass_exch = exch_vel_s(i,j) * CS%Rho0 + mass_exch = exch_vel_s(i,j) * CS%Rho_ocn Sbdry_it = (state%sss(i,j) * mass_exch + CS%Salin_ice * ISS%water_flux(i,j)) / & (mass_exch + ISS%water_flux(i,j)) dS_it = Sbdry_it - Sbdry(i,j) @@ -595,17 +593,17 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) fluxes%iceshelf_melt(:,:) = ISS%water_flux(:,:) * CS%flux_factor do j=js,je ; do i=is,ie - if ((iDens*state%ocean_mass(i,j) > CS%col_thick_melt_threshold) .and. & + if ((state%ocean_mass(i,j) > CS%col_mass_melt_threshold) .and. & (ISS%area_shelf_h(i,j) > 0.0) .and. (CS%isthermo)) then - ! Set melt to zero above a cutoff pressure (CS%Rho0*CS%cutoff_depth*CS%g_Earth). + ! Set melt to zero above a cutoff pressure (CS%Rho_ocn*CS%cutoff_depth*CS%g_Earth). ! This is needed for the ISOMIP test case. - if (ISS%mass_shelf(i,j) < CS%Rho0*CS%cutoff_depth) then + if (ISS%mass_shelf(i,j) < CS%Rho_ocn*CS%cutoff_depth) 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)) + haline_driving(i,j) = (ISS%water_flux(i,j) * Sbdry(i,j)) / (CS%Rho_ocn * exch_vel_s(i,j)) !!!!!!!!!!!!!!!!!!!!!!!!!!!!Safety checks !!!!!!!!!!!!!!!!!!!!!!!!! !1)Check if haline_driving computed above is consistent with @@ -739,20 +737,13 @@ subroutine change_thickness_using_melt(ISS, G, US, time_step, fluxes, density_ic ISS%hmask(i,j) = 0.0 ISS%area_shelf_h(i,j) = 0.0 endif + ISS%mass_shelf(i,j) = ISS%h_shelf(i,j) * density_ice endif enddo ; enddo call pass_var(ISS%area_shelf_h, G%domain) call pass_var(ISS%h_shelf, G%domain) call pass_var(ISS%hmask, G%domain) - - !### 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) * density_ice - endif - enddo ; enddo - call pass_var(ISS%mass_shelf, G%domain) end subroutine change_thickness_using_melt @@ -801,8 +792,7 @@ subroutine add_shelf_forces(G, US, CS, forces, do_shelf_area) call pass_vector(forces%frac_shelf_u, forces%frac_shelf_v, G%domain, TO_ALL, CGRID_NE) endif - !### Consider working over a smaller array range. - do j=jsd,jed ; do i=isd,ied + do j=js,je ; do i=is,ie press_ice = (ISS%area_shelf_h(i,j) * G%IareaT(i,j)) * & US%RZ_to_kg_m2*US%Z_to_m*US%s_to_T**2*(CS%g_Earth * ISS%mass_shelf(i,j)) if (associated(forces%p_surf)) then @@ -935,7 +925,7 @@ subroutine add_shelf_flux(G, US, CS, state, fluxes) call pass_vector(state%taux_shelf, state%tauy_shelf, G%domain, TO_ALL, CGRID_NE) ! 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 = US%m_to_Z*US%T_to_s*US%kg_m2s_to_RZ_T / CS%Rho0 +! Irho0 = US%m_to_Z*US%T_to_s*US%kg_m2s_to_RZ_T / CS%Rho_ocn ! 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 @@ -969,7 +959,7 @@ subroutine add_shelf_flux(G, US, CS, state, fluxes) ! Replace fluxes intercepted by the ice shelf with fluxes from the ice shelf frac_shelf = min(1.0, ISS%area_shelf_h(i,j) * G%IareaT(i,j)) frac_open = max(0.0, 1.0 - frac_shelf) - + if (associated(fluxes%sw)) fluxes%sw(i,j) = frac_open * fluxes%sw(i,j) if (associated(fluxes%sw_vis_dir)) fluxes%sw_vis_dir(i,j) = frac_open * fluxes%sw_vis_dir(i,j) if (associated(fluxes%sw_vis_dif)) fluxes%sw_vis_dif(i,j) = frac_open * fluxes%sw_vis_dif(i,j) @@ -1042,8 +1032,8 @@ subroutine add_shelf_flux(G, US, CS, state, fluxes) ! 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. & + ! Just consider the change in the mass of the floating shelf. + if ((state%ocean_mass(i,j) > CS%min_ocean_mass_float) .and. & (ISS%area_shelf_h(i,j) > 0.0)) then delta_float_mass(i,j) = ISS%mass_shelf(i,j) - last_mass_shelf(i,j) else @@ -1127,6 +1117,8 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl real :: L_rescale ! A rescaling factor for horizontal lengths from the representation in ! a restart file to the internal representation in this run. real :: meltrate_conversion ! The conversion factor to use for in the melt rate diagnostic. + real :: dz_ocean_min_float ! The minimum ocean thickness above which the ice shelf is considered + ! to be floating when CONST_SEA_LEVEL = True [m]. real :: cdrag, drag_bg_vel logical :: new_sim, save_IC, var_force !This include declares and sets the variable "version". @@ -1139,6 +1131,8 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl logical :: read_TideAmp, shelf_mass_is_dynamic, debug character(len=240) :: Tideamp_file real :: utide ! A tidal velocity [L T-1 ~> m s-1] + real :: col_thick_melt_thresh ! An ocean column thickness below which iceshelf melting + ! does not occur [m] if (associated(CS)) then call MOM_error(FATAL, "MOM_ice_shelf.F90, initialize_ice_shelf: "// & "called with an associated control structure.") @@ -1246,6 +1240,10 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl "ISOMIP+ experiments (Ocean3 and Ocean4). "//& "IMPORTANT: it is not currently possible to do "//& "prefect restarts using this flag.", default=.false.) + call get_param(param_file, mdl, "MIN_OCEAN_FLOAT_THICK", dz_ocean_min_float, & + "The minimum ocean thickness above which the ice shelf is considered to be "//& + "floating when CONST_SEA_LEVEL = True.", & + default=0.1, units="m", do_not_log=.not.CS%constant_sea_level) call get_param(param_file, mdl, "ISOMIP_S_SUR_SPONGE", CS%S0, & "Surface salinity in the restoring region.", & @@ -1303,15 +1301,16 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl "The heat capacity of sea water, approximated as a constant. "//& "The default value is from the TEOS-10 definition of conservative temperature.", & units="J kg-1 K-1", default=3991.86795711963, scale=US%J_kg_to_Q) - call get_param(param_file, mdl, "RHO_0", CS%Rho0, & + call get_param(param_file, mdl, "RHO_0", CS%Rho_ocn, & "The mean ocean density used with BOUSSINESQ true to "//& "calculate accelerations and the mass for conservation "//& "properties, or with BOUSSINSEQ false to convert some "//& "parameters from vertical units of m to kg m-2.", & - units="kg m-3", default=1035.0, scale=US%kg_m3_to_R) !### MAKE THIS A SEPARATE PARAMETER. + units="kg m-3", default=1035.0, scale=US%kg_m3_to_R) call get_param(param_file, mdl, "C_P_ICE", CS%Cp_ice, & "The heat capacity of ice.", units="J kg-1 K-1", scale=US%J_kg_to_Q, & default=2.10e3) + if (CS%constant_sea_level) CS%min_ocean_mass_float = dz_ocean_min_float*CS%Rho_ocn call get_param(param_file, mdl, "ICE_SHELF_FLUX_FACTOR", CS%flux_factor, & "Non-dimensional factor applied to shelf thermodynamic "//& @@ -1334,17 +1333,15 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl call get_param(param_file, mdl, "KD_TEMP_MOLECULAR", CS%kd_molec_temp, & "The molecular diffusivity of heat in sea water at the "//& "freezing point.", units="m2 s-1", default=1.41e-7, scale=US%m2_s_to_Z2_T) - 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.) call get_param(param_file, mdl, "DT_FORCING", CS%time_step, & "The time step for changing forcing, coupling with other "//& "components, or potentially writing certain diagnostics. "//& "The default value is given by DT.", units="s", default=0.0) - 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", & + call get_param(param_file, mdl, "COL_THICK_MELT_THRESHOLD", col_thick_melt_thresh, & + "The minimum ocean column thickness where melting is allowed.", units="m", & default=0.0) + CS%col_mass_melt_threshold = CS%Rho_ocn * col_thick_melt_thresh call get_param(param_file, mdl, "READ_TIDEAMP", read_TIDEAMP, & "If true, read a file (given by TIDEAMP_FILE) containing "//& From 7cdffb103b4344899025498569f5b5e0ac23efe1 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 1 Apr 2020 18:12:25 -0400 Subject: [PATCH 141/316] (*)Use state%taux_shelf to set state%ustar_shelf If possible, use state%taux_shelf and %tauy_shelf to set state%ustar_shelf, or if these are not available use the (now appropriately staggered) state%u and state%v to set ustar%shelf. In addition, ustar%shelf is set in all cases with a thermodynamically interactive ice shelf, and not just those that use the 3-equation expressions for the skin salinity. In addition, when CONST_SEA_LEVEL is true, the balancing flux occurs over all open ocean area, although the previous mode of using a hard-coded region is still there in commented out code. These code changes alter answers in all cases with a thermodynamically interactive ice shelf, but the solutions in the MOM6-examples test cases are bitwise identical. --- src/ice_shelf/MOM_ice_shelf.F90 | 147 +++++++++++++++----------------- 1 file changed, 68 insertions(+), 79 deletions(-) diff --git a/src/ice_shelf/MOM_ice_shelf.F90 b/src/ice_shelf/MOM_ice_shelf.F90 index cd9903bc82..733245b1ce 100644 --- a/src/ice_shelf/MOM_ice_shelf.F90 +++ b/src/ice_shelf/MOM_ice_shelf.F90 @@ -110,7 +110,7 @@ module MOM_ice_shelf real :: Gamma_S_3EQ !< Nondimensional salt-transfer coefficient, used in the 3Eq. formulation !< This number should be specified by the user. real :: col_mass_melt_threshold !< An ocean column mass below the iceshelf below which melting - !! does not occur [kg m-2] + !! does not occur [R Z ~> kg m-2] logical :: mass_from_file !< Read the ice shelf mass from a file every dt !!!! PHYSICAL AND NUMERICAL PARAMETERS FOR ICE DYNAMICS !!!!!! @@ -153,7 +153,7 @@ module MOM_ice_shelf !! fluxes. It will avoid large increase in sea level. real :: min_ocean_mass_float !< The minimum ocean mass per unit area before the ice !! shelf is considered to float when constant_sea_level - !! is used [kg m-2] + !! is used [R Z ~> kg m-2] real :: cutoff_depth !< Depth above which melt is set to zero (>= 0) [Z ~> m]. logical :: find_salt_root !< If true, if true find Sbdry using a quadratic eq. real :: TFr_0_0 !< The freezing point at 0 pressure and 0 salinity [degC] @@ -272,7 +272,13 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) real :: wB_flux_new, dDwB_dwB_in real :: I_Gam_T, I_Gam_S real :: dG_dwB ! The derivative of Gam_turb with wB [T3 Z-2 ~> s3 m-2] - real :: Isqrt2 + real :: taux2, tauy2 ! The squared surface stresses [Pa]. + real :: u2_av, v2_av ! The ice-area weighted average squared ocean velocities [L2 T-2 ~> m2 s-2] + real :: asu1, asu2 ! Ocean areas covered by ice shelves at neighboring u- + real :: asv1, asv2 ! and v-points [L2 ~> m2]. + real :: I_au, I_av ! The Adcroft reciprocals of the ice shelf areas at adjacent points [L-2 ~> m-2] + real :: Irho0 ! The inverse of the mean density times unit conversion factors that + ! arise because state uses MKS units [L2 m s2 kg-1 T-2 ~> m3 kg-1]. logical :: Sb_min_set, Sb_max_set 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 @@ -297,7 +303,6 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) PR = CS%kv_molec/CS%kd_molec_temp I_VK = 1.0/VK RhoCp = CS%Rho_ocn * CS%Cp - Isqrt2 = 1.0/sqrt(2.0) !first calculate molecular component Gam_mol_t = 12.5 * (PR**c2_3) - 6 @@ -332,6 +337,37 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) call hchksum(state%ocean_mass, "ocean_mass before apply melting", G%HI, haloshift=0) endif + ! Calculate the friction velocity under ice shelves, using taux_shelf and tauy_shelf if possible. + if (allocated(state%taux_shelf) .and. allocated(state%tauy_shelf)) then + call pass_vector(state%taux_shelf, state%tauy_shelf, G%domain, TO_ALL, CGRID_NE) + endif + Irho0 = US%m_s_to_L_T**2*US%kg_m3_to_R / CS%Rho_ocn + do j=js,je ; do i=is,ie ; if (fluxes%frac_shelf_h(i,j) > 0.0) then + taux2 = 0.0 ; tauy2 = 0.0 ; u2_av = 0.0 ; v2_av = 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)) + I_au = 0.0 ; if (asu1 + asu2 > 0.0) I_au = 1.0 / (asu1 + asu2) + I_av = 0.0 ; if (asv1 + asv2 > 0.0) I_av = 1.0 / (asv1 + asv2) + if (allocated(state%taux_shelf) .and. allocated(state%tauy_shelf)) then + taux2 = (asu1 * state%taux_shelf(I-1,j)**2 + asu2 * state%taux_shelf(I,j)**2 ) * I_au + tauy2 = (asv1 * state%tauy_shelf(i,J-1)**2 + asv2 * state%tauy_shelf(i,J)**2 ) * I_av + endif + u2_av = US%m_s_to_L_T**2*(asu1 * state%u(I-1,j)**2 + asu2 * state%u(I,j)**2) * I_au + v2_av = US%m_s_to_L_T**2*(asv1 * state%v(i,J-1)**2 + asu2 * state%v(i,J)**2) * I_av + + if (taux2 + tauy2 > 0.0) then + fluxes%ustar_shelf(i,j) = MAX(CS%ustar_bg, US%L_to_Z * & + sqrt(Irho0 * sqrt(taux2 + tauy2) + CS%cdrag*CS%utide(i,j)**2)) + else ! Take care of the cases when taux_shelf is not set or not allocated. + fluxes%ustar_shelf(i,j) = MAX(CS%ustar_bg, US%L_TO_Z * & + sqrt(CS%cdrag*((u2_av + v2_av) + CS%utide(i,j)**2))) + endif + else ! There is no shelf here. + fluxes%ustar_shelf(i,j) = 0.0 + endif ; enddo ; enddo + do j=js,je ! Find the pressure at the ice-ocean interface, averaged only over the ! part of the cell covered by ice shelf. @@ -344,11 +380,7 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) dR0_dT, dR0_dS, is, ie-is+1, CS%eqn_of_state) do i=is,ie - ! set ustar_shelf to zero. This is necessary if shelf_mass_is_dynamic - ! but it won't make a difference otherwise. - fluxes%ustar_shelf(i,j)= 0.0 - - if ((state%ocean_mass(i,j) > CS%col_mass_melt_threshold) .and. & + if ((state%ocean_mass(i,j) > US%RZ_to_kg_m2*CS%col_mass_melt_threshold) .and. & (ISS%area_shelf_h(i,j) > 0.0) .and. CS%isthermo) then if (CS%threeeq) then @@ -356,22 +388,8 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) ! salinity just below the ice-shelf as the variable that is being ! iterated for. - ! ### SHOULD USTAR_SHELF BE SET YET, or should it be set from taux_shelf & tauy_shelf? - ! I think that if taux_shelf and tauy_shelf have been calculated by the - ! ocean stress calculation, they should be used here or later to set ustar_shelf. - RWH - fluxes%ustar_shelf(i,j) = MAX(CS%ustar_bg, US%L_TO_Z * & - sqrt(CS%cdrag*(US%m_s_to_L_T**2*(state%u(i,j)**2 + state%v(i,j)**2) + CS%utide(i,j)**2))) - ustar_h = fluxes%ustar_shelf(i,j) - ! I think that the following can be deleted without causing any problems. - ! if (allocated(state%taux_shelf) .and. allocated(state%tauy_shelf)) then - ! ! These arrays are supposed to be stress components at C-grid points, which is - ! ! inconsistent with what is coded up here. - ! state%taux_shelf(i,j) = US%RZ_T_to_kg_m2s*US%Z_to_m*US%s_to_T * ustar_h**2 * CS%Rho_ocn*Isqrt2 - ! state%tauy_shelf(i,j) = state%taux_shelf(i,j) - ! endif - ! Estimate the neutral ocean boundary layer thickness as the minimum of the ! reported ocean mixed layer thickness and the neutral Ekman depth. absf = 0.25*((abs(G%CoriolisBu(I,J)) + abs(G%CoriolisBu(I-1,J-1))) + & @@ -593,7 +611,7 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) fluxes%iceshelf_melt(:,:) = ISS%water_flux(:,:) * CS%flux_factor do j=js,je ; do i=is,ie - if ((state%ocean_mass(i,j) > CS%col_mass_melt_threshold) .and. & + if ((state%ocean_mass(i,j) > US%RZ_to_kg_m2*CS%col_mass_melt_threshold) .and. & (ISS%area_shelf_h(i,j) > 0.0) .and. (CS%isthermo)) then ! Set melt to zero above a cutoff pressure (CS%Rho_ocn*CS%cutoff_depth*CS%g_Earth). @@ -869,20 +887,16 @@ subroutine add_shelf_flux(G, US, CS, state, fluxes) 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 times unit conversion factors that - !! arise because state uses MKS units [Z2 m s2 kg-1 T-2 ~> m3 kg-1]. real :: frac_shelf !< The fractional area covered by the ice shelf [nondim]. real :: frac_open !< The fractional area of the ocean that is not covered by the ice shelf [nondim]. real :: delta_mass_shelf!< Change in ice shelf mass over one time step [kg s-1] - real :: taux2, tauy2 !< The squared surface stresses [Pa]. real :: press_ice !< The pressure of the ice shelf per unit area of ocean (not ice) [Pa]. - real :: asu1, asu2 !< Ocean areas covered by ice shelves at neighboring u- - real :: asv1, asv2 !< and v-points [L2 ~> m2]. - real :: mean_melt_flux !< Spatial mean melt flux [R Z T-1 ~> kg m-2 s-1] - real :: sponge_area !< total area of sponge region [m2] + real :: balancing_flux !< The fresh water flux that balances the integrated melt flux [R Z T-1 ~> kg m-2 s-1] + real :: balancing_area !< total area where the balancing flux is applied [m2] type(time_type) :: dTime !< The time step as a time_type type(time_type) :: Time0 !< The previous time (Time-dt) - real, dimension(SZDI_(G),SZDJ_(G)) :: in_sponge !< 1 where the property damping occurs, 0 otherwise [nondim] + real, dimension(SZDI_(G),SZDJ_(G)) :: bal_frac !< Fraction of the cel1 where the mass flux + !! balancing the net melt flux occurs, 0 to 1 [nondim] real, dimension(SZDI_(G),SZDJ_(G)) :: last_mass_shelf !< Ice shelf mass !! at at previous time (Time-dt) [R Z ~> kg m-2] real, dimension(SZDI_(G),SZDJ_(G)) :: delta_float_mass !< The change in the floating mass between @@ -921,29 +935,6 @@ subroutine add_shelf_flux(G, US, CS, state, fluxes) endif endif - if (allocated(state%taux_shelf) .and. allocated(state%tauy_shelf)) then - call pass_vector(state%taux_shelf, state%tauy_shelf, G%domain, TO_ALL, CGRID_NE) - ! 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 = US%m_to_Z*US%T_to_s*US%kg_m2s_to_RZ_T / CS%Rho_ocn -! 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 - endif - 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) & @@ -990,15 +981,12 @@ subroutine add_shelf_flux(G, US, CS, state, fluxes) call MOM_forcing_chksum("After adding shelf fluxes", fluxes, G, CS%US, haloshift=0) endif - ! keep sea level constant by removing mass in the sponge - ! region (via virtual precip, vprec). Apply additional - ! salt/heat fluxes so that the resultant surface buoyancy - ! forcing is ~ 0. + ! Keep sea level constant by removing mass via a balancing flux that might be applied + ! in the open ocean or the sponge region (via virtual precip, vprec). Apply additional + ! salt/heat fluxes so that the resultant surface buoyancy forcing is ~ 0. ! This is needed for some of the ISOMIP+ experiments. if (CS%constant_sea_level) then - !### This code has problems with hard coded constants that need 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 @@ -1033,7 +1021,7 @@ subroutine add_shelf_flux(G, US, CS, state, fluxes) ! get total ice shelf mass at (Time-dt) and (Time), in kg do j=js,je ; do i=is,ie ! Just consider the change in the mass of the floating shelf. - if ((state%ocean_mass(i,j) > CS%min_ocean_mass_float) .and. & + if ((state%ocean_mass(i,j) > US%RZ_to_kg_m2*CS%min_ocean_mass_float) .and. & (ISS%area_shelf_h(i,j) > 0.0)) then delta_float_mass(i,j) = ISS%mass_shelf(i,j) - last_mass_shelf(i,j) else @@ -1051,35 +1039,36 @@ subroutine add_shelf_flux(G, US, CS, state, fluxes) ! average total melt flux over sponge area do j=js,je ; do i=is,ie - !### 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 - in_sponge(i,j) = 1.0 + if ((G%mask2dT(i,j) > 0.0) .AND. (ISS%area_shelf_h(i,j) * G%IareaT(i,j) < 1.0)) then + ! Uncomment this for some ISOMIP cases: + ! .AND. (G%geoLonT(i,j) >= 790.0) .AND. (G%geoLonT(i,j) <= 800.0)) then + bal_frac(i,j) = max(1.0 - ISS%area_shelf_h(i,j) * G%IareaT(i,j), 0.0) else - in_sponge(i,j) = 0.0 + bal_frac(i,j) = 0.0 endif enddo ; enddo - sponge_area = global_area_integral(in_sponge, G) - if (sponge_area > 0.0) then - mean_melt_flux = US%kg_m2s_to_RZ_T*(global_area_integral(ISS%water_flux, G, scale=US%RZ_T_to_kg_m2s, & + balancing_area = global_area_integral(bal_frac, G) + if (balancing_area > 0.0) then + balancing_flux = US%kg_m2s_to_RZ_T*(global_area_integral(ISS%water_flux, G, scale=US%RZ_T_to_kg_m2s, & area=ISS%area_shelf_h) + & - delta_mass_shelf ) / sponge_area + delta_mass_shelf ) / balancing_area else - mean_melt_flux = 0.0 + balancing_flux = 0.0 endif ! apply fluxes do j=js,je ; do i=is,ie - if (in_sponge(i,j) > 0.0) then + if (bal_frac(i,j) > 0.0) then ! evap is negative, and vprec has units of [R Z T-1 ~> kg m-2 s-1] - fluxes%vprec(i,j) = -mean_melt_flux + fluxes%vprec(i,j) = -balancing_flux fluxes%sens(i,j) = fluxes%vprec(i,j) * CS%Cp * CS%T0 ! [ Q R Z T-1 ~> W /m^2 ] fluxes%salt_flux(i,j) = fluxes%vprec(i,j) * CS%S0*1.0e-3 ! [kgSalt/kg R Z T-1 ~> kgSalt m-2 s-1] endif enddo ; enddo if (CS%debug) then - write(mesg,*) 'Mean melt flux (kg/(m^2 s)), dt = ', mean_melt_flux*US%RZ_T_to_kg_m2s, CS%time_step + write(mesg,*) 'Balancing flux (kg/(m^2 s)), dt = ', balancing_flux*US%RZ_T_to_kg_m2s, CS%time_step call MOM_mesg(mesg) call MOM_forcing_chksum("After constant sea level", fluxes, G, CS%US, haloshift=0) endif @@ -1118,7 +1107,7 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl ! a restart file to the internal representation in this run. real :: meltrate_conversion ! The conversion factor to use for in the melt rate diagnostic. real :: dz_ocean_min_float ! The minimum ocean thickness above which the ice shelf is considered - ! to be floating when CONST_SEA_LEVEL = True [m]. + ! to be floating when CONST_SEA_LEVEL = True [Z ~> m]. real :: cdrag, drag_bg_vel logical :: new_sim, save_IC, var_force !This include declares and sets the variable "version". @@ -1243,7 +1232,7 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl call get_param(param_file, mdl, "MIN_OCEAN_FLOAT_THICK", dz_ocean_min_float, & "The minimum ocean thickness above which the ice shelf is considered to be "//& "floating when CONST_SEA_LEVEL = True.", & - default=0.1, units="m", do_not_log=.not.CS%constant_sea_level) + default=0.1, units="m", scale=US%m_to_Z, do_not_log=.not.CS%constant_sea_level) call get_param(param_file, mdl, "ISOMIP_S_SUR_SPONGE", CS%S0, & "Surface salinity in the restoring region.", & @@ -1339,8 +1328,8 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl "The default value is given by DT.", units="s", default=0.0) call get_param(param_file, mdl, "COL_THICK_MELT_THRESHOLD", col_thick_melt_thresh, & - "The minimum ocean column thickness where melting is allowed.", units="m", & - default=0.0) + "The minimum ocean column thickness where melting is allowed.", & + units="m", scale=US%m_to_Z, default=0.0) CS%col_mass_melt_threshold = CS%Rho_ocn * col_thick_melt_thresh call get_param(param_file, mdl, "READ_TIDEAMP", read_TIDEAMP, & @@ -1389,7 +1378,7 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl units="m", default=0.0, scale=US%m_to_Z) call get_param(param_file, mdl, "USTAR_SHELF_BG", CS%ustar_bg, & - "The minimum value of ustar under ice sheves.", & + "The minimum value of ustar under ice shelves.", & units="m s-1", default=0.0, scale=US%m_to_Z*US%T_to_s) call get_param(param_file, mdl, "CDRAG_SHELF", cdrag, & "CDRAG is the drag coefficient relating the magnitude of "//& From 43ebd34bb1f79042f787a06b13ade68f4f375217 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 2 Apr 2020 14:55:00 -0400 Subject: [PATCH 142/316] Removed spaces from a blank line --- src/framework/MOM_spatial_means.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/framework/MOM_spatial_means.F90 b/src/framework/MOM_spatial_means.F90 index d4b687b0a5..2423a19433 100644 --- a/src/framework/MOM_spatial_means.F90 +++ b/src/framework/MOM_spatial_means.F90 @@ -56,7 +56,7 @@ function global_area_integral(var, G, scale, area) real, dimension(SZI_(G),SZJ_(G)), optional, intent(in) :: area !< The alternate area to use, including !! any required masking [L2 ~> m2]. real :: global_area_integral !< The returned area integral, usually in the units of var times [m2]. - + ! Local variables real, dimension(SZI_(G),SZJ_(G)) :: tmpForSumming real :: scalefac ! An overall scaling factor for the areas and variable. From 1a4c2ec7527386c6f8f19f0bb48f84e5341c3cab Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 2 Apr 2020 17:09:42 -0400 Subject: [PATCH 143/316] +Rescaled units of forces%rigidity_u and mass_berg Rescaled the units of forces%rigidity_ice_u and forces%rigidity_ice_v to [L4 Z-1 T-1] and the units of forces%mass_berg and fluxes%mass_berg to [R Z], as well as several internal related variables like internal ice viscosities and some ice densities. All answers and output files are bitwise identical, but there are changes to the units of elements in transparent types. --- .../MOM_surface_forcing_gfdl.F90 | 41 +++++++++--------- .../mct_driver/mom_surface_forcing_mct.F90 | 39 ++++++++--------- .../mom_surface_forcing_nuopc.F90 | 43 +++++++++---------- src/core/MOM_barotropic.F90 | 5 +-- src/core/MOM_forcing_type.F90 | 22 +++++----- src/ice_shelf/MOM_ice_shelf.F90 | 11 ++--- src/ice_shelf/MOM_marine_ice.F90 | 13 +++--- 7 files changed, 87 insertions(+), 87 deletions(-) diff --git a/config_src/coupled_driver/MOM_surface_forcing_gfdl.F90 b/config_src/coupled_driver/MOM_surface_forcing_gfdl.F90 index 860ba90487..9a277156af 100644 --- a/config_src/coupled_driver/MOM_surface_forcing_gfdl.F90 +++ b/config_src/coupled_driver/MOM_surface_forcing_gfdl.F90 @@ -102,11 +102,11 @@ module MOM_surface_forcing_gfdl 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 :: G_Earth !< Gravitational acceleration [m s-2] - real :: Kv_sea_ice !< Viscosity in sea-ice that resists sheared vertical motions [m2 s-1] - real :: density_sea_ice !< Typical density of sea-ice [kg m-3]. The value is only used to convert + real :: Kv_sea_ice !< Viscosity in sea-ice that resists sheared vertical motions [L4 Z-2 T-1 ~> m2 s-1] + real :: density_sea_ice !< Typical density of sea-ice [R ~> 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 [kg m-2], typically of order 1000 kg m-2. + !! becomes effective [R Z ~> kg m-2], typically of order 1000 kg m-2. logical :: allow_flux_adjustments !< If true, use data_override to obtain flux adjustments logical :: restore_salt !< If true, the coupled MOM driver adds a term to restore surface @@ -466,7 +466,7 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, endif if (associated(IOB%mass_berg)) then - fluxes%mass_berg(i,j) = IOB%mass_berg(i-i0,j-j0) * G%mask2dT(i,j) + fluxes%mass_berg(i,j) = US%m_to_Z*US%kg_m3_to_R * IOB%mass_berg(i-i0,j-j0) * G%mask2dT(i,j) if (CS%check_no_land_fluxes) & call check_mask_val_consistency(IOB%mass_berg(i-i0,j-j0), G%mask2dT(i,j), i, j, 'mass_berg', G) endif @@ -669,14 +669,14 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS, dt_ ! Local variables real, dimension(SZI_(G),SZJ_(G)) :: & - rigidity_at_h, & ! Ice rigidity at tracer points [m3 s-1] + rigidity_at_h, & ! Ice rigidity at tracer points [L4 Z-1 T-1 ~> m3 s-1] net_mass_src, & ! A temporary of net mass sources [kg m-2 s-1]. ustar_tmp ! A temporary array of ustar values [Z T-1 ~> m s-1]. - real :: I_GEarth ! 1.0 / G_Earth [s2 m-1] - real :: Kv_rho_ice ! (CS%kv_sea_ice / CS%density_sea_ice) [m5 s-1 kg-1] - 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] + real :: I_GEarth ! Unit conversion factors times 1.0 / G_Earth [Z R m s2 kg-1 ~> s2 m-1] + real :: Kv_rho_ice ! (CS%Kv_sea_ice / CS%density_sea_ice) [L4 Z-2 T-1 R-1 ~> m5 s-1 kg-1] + real :: mass_ice ! mass of sea ice at a face [R Z ~> kg m-2] + real :: mass_eff ! effective mass of sea ice for rigidity [R Z ~> kg m-2] real :: wt1, wt2 ! Relative weights of previous and current values of ustar, ND. integer :: i, j, is, ie, js, je, Isq, Ieq, Jsq, Jeq, i0, j0 @@ -816,13 +816,13 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS, dt_ enddo ; enddo ; endif if (associated(IOB%mass_berg)) then ; do j=js,je ; do i=is,ie - forces%mass_berg(i,j) = IOB%mass_berg(i-i0,j-j0) * G%mask2dT(i,j) + forces%mass_berg(i,j) = US%m_to_Z*US%kg_m3_to_R * IOB%mass_berg(i-i0,j-j0) * G%mask2dT(i,j) enddo ; enddo ; endif ! Obtain sea ice related dynamic fields if (associated(IOB%ice_rigidity)) then do j=js,je ; do i=is,ie - rigidity_at_h(i,j) = IOB%ice_rigidity(i-i0,j-j0) * G%mask2dT(i,j) + rigidity_at_h(i,j) = US%m_to_L**3*US%Z_to_L*US%T_to_s * IOB%ice_rigidity(i-i0,j-j0) * G%mask2dT(i,j) enddo ; enddo call pass_var(rigidity_at_h, G%Domain, halo=1) do I=is-1,ie ; do j=js,je @@ -837,14 +837,13 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS, dt_ if (CS%rigid_sea_ice) then call pass_var(forces%p_surf_full, G%Domain, halo=1) - I_GEarth = 1.0 / CS%G_Earth - Kv_rho_ice = (CS%kv_sea_ice / CS%density_sea_ice) + I_GEarth = US%m_to_Z*US%kg_m3_to_R / CS%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) + 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 @@ -852,8 +851,7 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS, dt_ 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) + 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 @@ -1518,15 +1516,16 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS) units="m s-2", default = 9.80) call get_param(param_file, mdl, "SEA_ICE_MEAN_DENSITY", CS%density_sea_ice, & "A typical density of sea ice, used with the kinematic "//& - "viscosity, when USE_RIGID_SEA_ICE is true.", units="kg m-3", & - default=900.0) + "viscosity, when USE_RIGID_SEA_ICE is true.", & + units="kg m-3", default=900.0, scale=US%kg_m3_to_R) call get_param(param_file, mdl, "SEA_ICE_VISCOSITY", CS%Kv_sea_ice, & "The kinematic viscosity of sufficiently thick sea ice "//& "for use in calculating the rigidity of sea ice.", & - units="m2 s-1", default=1.0e9) + units="m2 s-1", default=1.0e9, scale=US%Z_to_L**2*US%m_to_L**2*US%T_to_s) 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 "//& - "starts to exhibit rigidity", units="kg m-2", default=1000.0) + "starts to exhibit rigidity", & + units="kg m-2", default=1000.0, scale=US%kg_m3_to_R*US%m_to_Z) endif call get_param(param_file, mdl, "ALLOW_ICEBERG_FLUX_DIAGNOSTICS", iceberg_flux_diags, & diff --git a/config_src/mct_driver/mom_surface_forcing_mct.F90 b/config_src/mct_driver/mom_surface_forcing_mct.F90 index 38bd54acf1..1154e046c7 100644 --- a/config_src/mct_driver/mom_surface_forcing_mct.F90 +++ b/config_src/mct_driver/mom_surface_forcing_mct.F90 @@ -96,13 +96,13 @@ module MOM_surface_forcing_mct !! to damp surface deflections (especially surface !! gravity waves). The default is false. real :: G_Earth !< Gravitational acceleration [m s-2] - real :: Kv_sea_ice !! viscosity in sea-ice that resists sheared vertical motions [m2 s-1] - real :: density_sea_ice !< typical density of sea-ice [kg m-3]. The value is + real :: Kv_sea_ice !! viscosity in sea-ice that resists sheared vertical motions [L4 Z-2 T-1 ~> m2 s-1] + real :: density_sea_ice !< typical density of sea-ice [R ~> 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]. + !! sea-ice viscosity becomes effective [R Z ~> 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 [Z T-1 ~> m s-1] logical :: salt_restore_as_sflux !< If true, SSS restore as salt flux instead of water flux @@ -456,7 +456,7 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, 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) + fluxes%mass_berg(i,j) = US%m_to_Z*US%kg_m3_to_R * IOB%mass_berg(i-i0,j-j0) * G%mask2dT(i,j) ! GMM, cime does not not have an equivalent for heat_content_lrunoff and ! heat_content_frunoff. I am setting these to zero for now. @@ -611,7 +611,7 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS) tauy_at_q !< Meridional wind stresses at q points [R Z L T-2 ~> Pa] real, dimension(SZI_(G),SZJ_(G)) :: & - rigidity_at_h, & !< Ice rigidity at tracer points [m3 s-1] + rigidity_at_h, & !< Ice rigidity at tracer points [L4 Z-1 T-1 ~> m3 s-1] taux_at_h, & !< Zonal wind stresses at h points [R Z L T-2 ~> Pa] tauy_at_h !< Meridional wind stresses at h points [R Z L T-2 ~> Pa] @@ -621,10 +621,10 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS) real :: tau_mag !< magnitude of the wind stress [R Z L T-2 ~> Pa] real :: Pa_conversion ! A unit conversion factor from Pa to the internal wind stress units [R Z L T-2 Pa-1 ~> 1] real :: stress_conversion ! A unit conversion factor from Pa times any stress multiplier [R Z L T-2 Pa-1 ~> 1] - real :: I_GEarth !< 1.0 / G%G_Earth [s2 m-1] - real :: Kv_rho_ice !< (CS%kv_sea_ice / CS%density_sea_ice) [m5 s-1 kg-1] - 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] + real :: I_GEarth !< Unit conversion factors times 1.0 / G_Earth [Z R m s2 kg-1 ~> s2 m-1] + real :: Kv_rho_ice !< (CS%Kv_sea_ice / CS%density_sea_ice) [L4 Z-2 T-1 R-1 ~> m5 s-1 kg-1] + real :: mass_ice !< mass of sea ice at a face [R Z ~> kg m-2] + real :: mass_eff !< effective mass of sea ice for rigidity [R Z ~> 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 @@ -721,10 +721,10 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS) 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) + forces%mass_berg(i,j) = US%m_to_Z*US%kg_m3_to_R * 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) + rigidity_at_h(i,j) = US%m_to_L**3*US%Z_to_L*US%T_to_s * 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) * stress_conversion @@ -845,14 +845,13 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS) if (CS%rigid_sea_ice) then call pass_var(forces%p_surf_full, G%Domain, halo=1) - I_GEarth = 1.0 / CS%G_Earth - Kv_rho_ice = (CS%kv_sea_ice / CS%density_sea_ice) + I_GEarth = US%m_to_Z*US%kg_m3_to_R / CS%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) + 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 @@ -860,8 +859,7 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS) 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) + 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 @@ -1279,10 +1277,11 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, restore_salt, call get_param(param_file, mdl, "SEA_ICE_VISCOSITY", CS%Kv_sea_ice, & "The kinematic viscosity of sufficiently thick sea ice "//& "for use in calculating the rigidity of sea ice.", & - units="m2 s-1", default=1.0e9) + units="m2 s-1", default=1.0e9, scale=US%Z_to_L**2*US%m_to_L**2*US%T_to_s) 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 "//& - "starts to exhibit rigidity", units="kg m-2", default=1000.0) + "starts to exhibit rigidity", & + units="kg m-2", default=1000.0, scale=US%kg_m3_to_R*US%m_to_Z) endif call get_param(param_file, mdl, "ALLOW_ICEBERG_FLUX_DIAGNOSTICS", iceberg_flux_diags, & diff --git a/config_src/nuopc_driver/mom_surface_forcing_nuopc.F90 b/config_src/nuopc_driver/mom_surface_forcing_nuopc.F90 index dea2ce1284..63e42f5475 100644 --- a/config_src/nuopc_driver/mom_surface_forcing_nuopc.F90 +++ b/config_src/nuopc_driver/mom_surface_forcing_nuopc.F90 @@ -99,13 +99,13 @@ module MOM_surface_forcing_nuopc !! to damp surface deflections (especially surface !! gravity waves). The default is false. real :: G_Earth !< Gravitational acceleration [m s-2] - real :: Kv_sea_ice !! viscosity in sea-ice that resists sheared vertical motions [m2 s-1] - real :: density_sea_ice !< typical density of sea-ice [kg m-3]. The value is + real :: Kv_sea_ice !! viscosity in sea-ice that resists sheared vertical motions [L4 Z-2 T-1 ~> m2 s-1] + real :: density_sea_ice !< typical density of sea-ice [R ~> 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]. + !! sea-ice viscosity becomes effective [R Z ~> kg m-2], + !! typically of order 1000 kg m-2. logical :: allow_flux_adjustments !< If true, use data_override to obtain flux adjustments logical :: liquid_runoff_from_data !< If true, use data_override to obtain liquid runoff @@ -461,7 +461,7 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, 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) + fluxes%mass_berg(i,j) = US%m_to_Z*US%kg_m3_to_R * IOB%mass_berg(i-i0,j-j0) * G%mask2dT(i,j) if (associated(IOB%lrunoff_hflx)) & fluxes%heat_content_lrunoff(i,j) = US%W_m2_to_QRZ_T * IOB%lrunoff_hflx(i-i0,j-j0) * G%mask2dT(i,j) @@ -608,7 +608,7 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS) 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) + rigidity_at_h, & !< Ice rigidity at tracer points [L4 Z-1 T-1 ~> m3 s-1] taux_at_h, & !< Zonal wind stresses at h points [Pa] tauy_at_h !< Meridional wind stresses at h points [Pa] @@ -618,10 +618,10 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS) real :: tau_mag !< magnitude of the wind stress [R Z L T-2 ~> Pa] real :: Pa_conversion ! A unit conversion factor from Pa to the internal wind stress units [R Z L T-2 Pa-1 ~> 1] real :: stress_conversion ! A unit conversion factor from Pa times any stress multiplier [R Z L T-2 Pa-1 ~> 1] - real :: I_GEarth !< 1.0 / G_Earth [s2 m-1] - 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) + real :: I_GEarth !< Unit conversion factors times 1.0 / G_Earth [Z R m s2 kg-1 ~> s2 m-1] + real :: Kv_rho_ice !< (CS%Kv_sea_ice / CS%density_sea_ice) [L4 Z-2 T-1 R-1 ~> m5 s-1 kg-1] + real :: mass_ice !< mass of sea ice at a face [R Z ~> kg m-2] + real :: mass_eff !< effective mass of sea ice for rigidity [R Z ~> 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 @@ -721,10 +721,10 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS) 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) + forces%mass_berg(i,j) = US%m_to_Z*US%kg_m3_to_R * 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) + rigidity_at_h(i,j) = US%m_to_L**3*US%Z_to_L*US%T_to_s * 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) * stress_conversion @@ -845,14 +845,13 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS) if (CS%rigid_sea_ice) then call pass_var(forces%p_surf_full, G%Domain, halo=1) - I_GEarth = 1.0 / CS%g_Earth - Kv_rho_ice = (CS%kv_sea_ice / CS%density_sea_ice) + I_GEarth = US%m_to_Z*US%kg_m3_to_R / CS%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) + 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 @@ -860,8 +859,7 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS) 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) + 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 @@ -1273,15 +1271,16 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, restore_salt, units="m s-2", default = 9.80) call get_param(param_file, mdl, "SEA_ICE_MEAN_DENSITY", CS%density_sea_ice, & "A typical density of sea ice, used with the kinematic "//& - "viscosity, when USE_RIGID_SEA_ICE is true.", units="kg m-3", & - default=900.0) + "viscosity, when USE_RIGID_SEA_ICE is true.", & + units="kg m-3", default=900.0, scale=US%kg_m3_to_R) call get_param(param_file, mdl, "SEA_ICE_VISCOSITY", CS%Kv_sea_ice, & "The kinematic viscosity of sufficiently thick sea ice "//& "for use in calculating the rigidity of sea ice.", & - units="m2 s-1", default=1.0e9) + units="m2 s-1", default=1.0e9, scale=US%Z_to_L**2*US%m_to_L**2*US%T_to_s) 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 "//& - "starts to exhibit rigidity", units="kg m-2", default=1000.0) + "starts to exhibit rigidity", & + units="kg m-2", default=1000.0, scale=US%kg_m3_to_R*US%m_to_Z) endif call get_param(param_file, mdl, "ALLOW_ICEBERG_FLUX_DIAGNOSTICS", iceberg_flux_diags, & diff --git a/src/core/MOM_barotropic.F90 b/src/core/MOM_barotropic.F90 index 5998f08c16..2cd6de8daf 100644 --- a/src/core/MOM_barotropic.F90 +++ b/src/core/MOM_barotropic.F90 @@ -1478,9 +1478,8 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, dyn_coef_max = CS%const_dyn_psurf * max(0.0, 1.0 - dtbt**2 * Idt_max2) / & (dtbt**2 * H_eff_dx2) - ! ice_strength has units of [L2 Z-1 T-2 ~> m s-2]. rigidity_ice_[uv] has units of [m3 s-1]. - ice_strength = US%m_to_L**4*US%Z_to_m*US%T_to_s* & - ((forces%rigidity_ice_u(I,j) + forces%rigidity_ice_u(I-1,j)) + & + ! ice_strength has units of [L2 Z-1 T-2 ~> m s-2]. rigidity_ice_[uv] has units of [L4 Z-1 T-1 ~> m3 s-1]. + ice_strength = ((forces%rigidity_ice_u(I,j) + forces%rigidity_ice_u(I-1,j)) + & (forces%rigidity_ice_v(i,J) + forces%rigidity_ice_v(i,J-1))) / & (CS%ice_strength_length**2 * dtbt) diff --git a/src/core/MOM_forcing_type.F90 b/src/core/MOM_forcing_type.F90 index b7260c2da6..99a50e1860 100644 --- a/src/core/MOM_forcing_type.F90 +++ b/src/core/MOM_forcing_type.F90 @@ -139,7 +139,7 @@ module MOM_forcing_type real, pointer, dimension(:,:) :: & ustar_berg => NULL(), & !< iceberg contribution to top ustar [Z T-1 ~> m s-1]. area_berg => NULL(), & !< area of ocean surface covered by icebergs [m2 m-2] - mass_berg => NULL() !< mass of icebergs [kg m-2] + mass_berg => NULL() !< mass of icebergs [R Z ~> kg m-2] ! land ice-shelf related inputs real, pointer, dimension(:,:) :: ustar_shelf => NULL() !< Friction velocity under ice-shelves [Z T-1 ~> m s-1]. @@ -166,7 +166,7 @@ module MOM_forcing_type !! type variable has not yet been inialized. logical :: gustless_accum_bug = .true. !< If true, use an incorrect expression in the time !! average of the gustless wind stress. - real :: C_p !< heat capacity of seawater [J kg-1 degC-1]. + real :: C_p !< heat capacity of seawater [Q degC-1 ~> J kg-1 degC-1]. !! C_p is is the same value as in thermovar_ptrs_type. ! passive tracer surface fluxes @@ -208,7 +208,7 @@ module MOM_forcing_type ! iceberg related inputs real, pointer, dimension(:,:) :: & area_berg => NULL(), & !< fractional area of ocean surface covered by icebergs [m2 m-2] - mass_berg => NULL() !< mass of icebergs per unit ocean area [kg m-2] + mass_berg => NULL() !< mass of icebergs per unit ocean area [R Z ~> kg m-2] ! land ice-shelf related inputs real, pointer, dimension(:,:) :: frac_shelf_u => NULL() !< Fractional ice shelf coverage of u-cells, @@ -218,8 +218,10 @@ module MOM_forcing_type !! nondimensional from 0 to 1 [nondim]. This is only associated if ice shelves are enabled, !! and is exactly 0 away from shelves or on land. real, pointer, dimension(:,:) :: & - rigidity_ice_u => NULL(), & !< Depth-integrated lateral viscosity of ice shelves or sea ice at u-points [m3 s-1] - rigidity_ice_v => NULL() !< Depth-integrated lateral viscosity of ice shelves or sea ice at v-points [m3 s-1] + rigidity_ice_u => NULL(), & !< Depth-integrated lateral viscosity of ice shelves or sea ice at + !! u-points [L4 Z-1 T-1 ~> m3 s-1] + rigidity_ice_v => NULL() !< Depth-integrated lateral viscosity of ice shelves or sea ice at + !! v-points [L4 Z-1 T-1 ~> m3 s-1] real :: dt_force_accum = -1.0 !< The amount of time over which the mechanical forcing fluxes !! have been averaged [s]. logical :: net_mass_src_set = .false. !< If true, an estimate of net_mass_src has been provided. @@ -1116,14 +1118,14 @@ subroutine MOM_mech_forcing_chksum(mesg, forces, G, US, haloshift) ! and js...je as their extent. if (associated(forces%taux) .and. associated(forces%tauy)) & call uvchksum(mesg//" forces%tau[xy]", forces%taux, forces%tauy, G%HI, & - haloshift=hshift, symmetric=.true., scale=US%R_to_kg_m3*US%L_T_to_m_s**2*US%Z_to_L) + haloshift=hshift, symmetric=.true., scale=US%RZ_T_to_kg_m2s*US%L_T_to_m_s) if (associated(forces%p_surf)) & call hchksum(forces%p_surf, mesg//" forces%p_surf",G%HI,haloshift=hshift) if (associated(forces%ustar)) & - call hchksum(forces%ustar, mesg//" forces%ustar",G%HI,haloshift=hshift, scale=US%Z_to_m*US%s_to_T) + call hchksum(forces%ustar, mesg//" forces%ustar", G%HI, haloshift=hshift, scale=US%Z_to_m*US%s_to_T) if (associated(forces%rigidity_ice_u) .and. associated(forces%rigidity_ice_v)) & - call uvchksum(mesg//" forces%rigidity_ice_[uv]", forces%rigidity_ice_u, & - forces%rigidity_ice_v, G%HI, haloshift=hshift, symmetric=.true.) + call uvchksum(mesg//" forces%rigidity_ice_[uv]", forces%rigidity_ice_u, forces%rigidity_ice_v, & + G%HI, haloshift=hshift, symmetric=.true., scale=US%L_to_m**3*US%L_to_Z*US%s_to_T) end subroutine MOM_mech_forcing_chksum @@ -1255,7 +1257,7 @@ subroutine register_forcing_type_diags(Time, diag, US, use_temperature, handles, 'Area of grid cell covered by iceberg ', 'm2 m-2') handles%id_mass_berg = register_diag_field('ocean_model', 'mass_berg', diag%axesT1, Time, & - 'Mass of icebergs ', 'kg m-2') + 'Mass of icebergs ', 'kg m-2', conversion=US%RZ_to_kg_m2) handles%id_ustar_ice_cover = register_diag_field('ocean_model', 'ustar_ice_cover', diag%axesT1, Time, & 'Friction velocity below iceberg and ice shelf together', 'm s-1', conversion=US%Z_to_m*US%s_to_T) diff --git a/src/ice_shelf/MOM_ice_shelf.F90 b/src/ice_shelf/MOM_ice_shelf.F90 index d05631c621..eeef255629 100644 --- a/src/ice_shelf/MOM_ice_shelf.F90 +++ b/src/ice_shelf/MOM_ice_shelf.F90 @@ -98,7 +98,7 @@ module MOM_ice_shelf !< 2-equation formulation [Z T-1 ~> m s-1]. real :: Salin_ice !< The salinity of shelf ice [ppt]. real :: Temp_ice !< The core temperature of shelf ice [degC]. - real :: kv_ice !< The viscosity of ice [Z2 T-1 ~> m2 s-1]. + real :: kv_ice !< The viscosity of ice [L4 Z-2 T-1 ~> m2 s-1]. real :: density_ice !< A typical density of ice [R ~> kg m-3]. real :: kv_molec !< The molecular kinematic viscosity of sea water [Z2 T-1 ~> m2 s-1]. real :: kd_molec_salt!< The molecular diffusivity of salt [Z2 T-1 ~> m2 s-1]. @@ -763,7 +763,7 @@ subroutine add_shelf_forces(G, US, CS, forces, do_shelf_area) 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. - real :: kv_rho_ice ! The viscosity of ice divided by its density [m3 s-1 R-1 Z-1 ~> m5 kg-1 s-1]. + real :: kv_rho_ice ! The viscosity of ice divided by its density [L4 T-1 R-1 Z-2 ~> m5 kg-1 s-1]. real :: press_ice ! The pressure of the ice shelf per unit area of ocean (not ice) [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 @@ -816,7 +816,7 @@ subroutine add_shelf_forces(G, US, CS, forces, do_shelf_area) ! 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 = US%Z_to_m*US%Z2_T_to_m2_s*CS%kv_ice / CS%density_ice + 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) + & @@ -830,7 +830,7 @@ subroutine add_shelf_forces(G, US, CS, forces, do_shelf_area) if (CS%debug) then call uvchksum("rigidity_ice_[uv]", forces%rigidity_ice_u, forces%rigidity_ice_v, & - G%HI, symmetric=.true.) + G%HI, symmetric=.true., scale=US%L_to_m**3*US%L_to_Z*US%s_to_T) call uvchksum("frac_shelf_[uv]", forces%frac_shelf_u, forces%frac_shelf_v, & G%HI, symmetric=.true.) endif @@ -1292,7 +1292,8 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl "fluxes.", units="none", default=1.0) call get_param(param_file, mdl, "KV_ICE", CS%kv_ice, & - "The viscosity of the ice.", units="m2 s-1", default=1.0e10, scale=US%m2_s_to_Z2_T) + "The viscosity of the ice.", & + units="m2 s-1", default=1.0e10, scale=US%Z_to_L**2*US%m_to_L**2*US%T_to_s) call get_param(param_file, mdl, "KV_MOLECULAR", CS%kv_molec, & "The molecular kinimatic viscosity of sea water at the "//& "freezing temperature.", units="m2 s-1", default=1.95e-6, scale=US%m2_s_to_Z2_T) diff --git a/src/ice_shelf/MOM_marine_ice.F90 b/src/ice_shelf/MOM_marine_ice.F90 index 780cc8c3cd..30121d0c8e 100644 --- a/src/ice_shelf/MOM_marine_ice.F90 +++ b/src/ice_shelf/MOM_marine_ice.F90 @@ -26,12 +26,12 @@ module MOM_marine_ice !> Control structure for MOM_marine_ice type, public :: marine_ice_CS ; private - real :: kv_iceberg !< The viscosity of the icebergs [m2 s-1] (for ice rigidity) + real :: kv_iceberg !< The viscosity of the icebergs [L4 Z-2 T-1 ~> m2 s-1] (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 [Q ~> J kg-1] - real :: density_iceberg !< A typical density of icebergs [kg m-3] (for ice rigidity) + real :: density_iceberg !< A typical density of icebergs [R ~> kg m-3] (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. @@ -51,7 +51,7 @@ subroutine iceberg_forces(G, forces, use_ice_shelf, sfc_state, time_step, CS) real, intent(in) :: time_step !< The coupling time step [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 [m5 kg-1 s-1]. + real :: kv_rho_ice ! The viscosity of ice divided by its density [L4 Z-2 T-1 R-1 ~> 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) @@ -83,7 +83,7 @@ subroutine iceberg_forces(G, forces, use_ice_shelf, sfc_state, time_step, CS) (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)) + 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)) & @@ -190,9 +190,10 @@ subroutine marine_ice_init(Time, G, param_file, diag, CS) 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) + "The viscosity of the icebergs", & + units="m2 s-1", default=1.0e10, scale=G%US%Z_to_L**2*G%US%m_to_L**2*G%US%T_to_s) call get_param(param_file, mdl, "DENSITY_ICEBERGS", CS%density_iceberg, & - "A typical density of icebergs.", units="kg m-3", default=917.0) + "A typical density of icebergs.", units="kg m-3", default=917.0, scale=G%US%kg_m3_to_R) call get_param(param_file, mdl, "LATENT_HEAT_FUSION", CS%latent_heat_fusion, & "The latent heat of fusion.", units="J/kg", default=hlf, scale=G%US%J_kg_to_Q) call get_param(param_file, mdl, "BERG_AREA_THRESHOLD", CS%berg_area_threshold, & From f75edd93a554d94770793c482ee4796860d37b5b Mon Sep 17 00:00:00 2001 From: Kate Hedstrom Date: Thu, 2 Apr 2020 21:25:05 -0800 Subject: [PATCH 144/316] Added a ramp option for SSH OBCs. --- src/core/MOM_dynamics_split_RK2.F90 | 11 ++++- src/core/MOM_open_boundary.F90 | 77 +++++++++++++++++++++++++++-- 2 files changed, 82 insertions(+), 6 deletions(-) diff --git a/src/core/MOM_dynamics_split_RK2.F90 b/src/core/MOM_dynamics_split_RK2.F90 index db9d1ada73..8c0decd8c1 100644 --- a/src/core/MOM_dynamics_split_RK2.F90 +++ b/src/core/MOM_dynamics_split_RK2.F90 @@ -49,7 +49,7 @@ module MOM_dynamics_split_RK2 use MOM_MEKE_types, only : MEKE_type use MOM_open_boundary, only : ocean_OBC_type, radiation_open_bdry_conds use MOM_open_boundary, only : open_boundary_zero_normal_flow -use MOM_open_boundary, only : open_boundary_test_extern_h +use MOM_open_boundary, only : open_boundary_test_extern_h, update_OBC_ramp use MOM_PressureForce, only : PressureForce, PressureForce_init, PressureForce_CS use MOM_set_visc, only : set_viscous_ML, set_visc_CS use MOM_thickness_diffuse, only : thickness_diffuse_CS @@ -364,6 +364,9 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, Time_local, dt, forces, p_s if (associated(CS%OBC)) then if (CS%debug_OBC) call open_boundary_test_extern_h(G, GV, CS%OBC, h) + ! Update OBC ramp value as function of time + call update_OBC_ramp(Time_local, CS%OBC) + do k=1,nz ; do j=G%jsd,G%jed ; do I=G%IsdB,G%IedB u_old_rad_OBC(I,j,k) = u_av(I,j,k) enddo ; enddo ; enddo @@ -1120,7 +1123,11 @@ subroutine initialize_dyn_split_RK2(u, v, h, uh, vh, eta, Time, G, GV, US, param activate=is_new_run(restart_CS) ) if (associated(ALE_CSp)) CS%ALE_CSp => ALE_CSp - if (associated(OBC)) CS%OBC => OBC + if (associated(OBC)) then + CS%OBC => OBC + if (OBC%ramp) call update_OBC_ramp(Time, CS%OBC, & + activate=is_new_run(restart_CS) ) + endif if (associated(update_OBC_CSp)) CS%update_OBC_CSp => update_OBC_CSp eta_rest_name = "sfc" ; if (.not.GV%Boussinesq) eta_rest_name = "p_bot" diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index 927548665e..3b1559ab81 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -9,6 +9,7 @@ module MOM_open_boundary use MOM_domains, only : pass_var, pass_vector use MOM_domains, only : To_All, SCALAR_PAIR, CGRID_NE use MOM_error_handler, only : MOM_mesg, MOM_error, FATAL, WARNING, is_root_pe +use MOM_error_handler, only : NOTE use MOM_file_parser, only : get_param, log_version, param_file_type, log_param use MOM_grid, only : ocean_grid_type, hor_index_type use MOM_dyn_horgrid, only : dyn_horgrid_type @@ -18,6 +19,7 @@ module MOM_open_boundary use MOM_restart, only : register_restart_field, query_initialized, 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_time_manager, only : time_type, time_type_to_real, operator(-) use MOM_tracer_registry, only : tracer_type, tracer_registry_type, tracer_name_lookup use time_interp_external_mod, only : init_external_field, time_interp_external use time_interp_external_mod, only : time_interp_external_init @@ -54,6 +56,7 @@ module MOM_open_boundary public fill_temp_salt_segments public open_boundary_register_restarts public update_segment_tracer_reservoirs +public update_OBC_ramp integer, parameter, public :: OBC_NONE = 0 !< Indicates the use of no open boundary integer, parameter, public :: OBC_SIMPLE = 1 !< Indicates the use of a simple inflow open boundary @@ -280,6 +283,14 @@ module MOM_open_boundary !! the independence of the OBCs to this external data [H ~> m or kg m-2]. real :: silly_u !< A silly value of velocity outside of the domain that can be used to test !! the independence of the OBCs to this external data [L T-1 ~> m s-1]. + logical :: ramp = .false. !< If True, ramp from zero to the external values + !! for SSH. + logical :: ramping_is_activated = .false. !< True if the ramping has been initialized + real :: ramp_timescale !< If ramp is True, use this timescale for ramping. + real :: trunc_ramp_time !< If ramp is True, time after which ramp is done. + real :: ramp_value !< If ramp is True, where we are on the ramp from + !! zero to one. + type(time_type) :: ramp_start_time !< Time when model was started. end type ocean_OBC_type !> Control structure for open boundaries that read from files. @@ -402,6 +413,14 @@ subroutine open_boundary_config(G, US, param_file, OBC) call get_param(param_file, mdl, "MASK_OUTSIDE_OBCS", mask_outside, & "If true, set the areas outside open boundaries to be land.", & default=.false.) + call get_param(param_file, mdl, "RAMP_OBCS", OBC%ramp, & + "If true, ramps from zero to the external values over time, with"//& + "a ramping timescale given by RAMP_TIMESCALE. Ramping SSH only so far", & + default=.false.) + call get_param(param_file, mdl, "OBC_RAMP_TIMESCALE", OBC%ramp_timescale, & + "If RAMP_OBCS is true, this sets the ramping timescale.", & + units="days", default=1.0, scale=86400.0*US%s_to_T) + call get_param(param_file, mdl, "DEBUG", debug, default=.false.) call get_param(param_file, mdl, "DEBUG_OBC", debug_OBC, default=.false.) if (debug_OBC .or. debug) & @@ -3873,11 +3892,19 @@ subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) endif if (trim(segment%field(m)%name) == 'SSH') then - do j=js_obc2,je_obc - do i=is_obc2,ie_obc - segment%eta(i,j) = segment%field(m)%buffer_dst(i,j,1) + if (OBC%ramp) then + do j=js_obc2,je_obc + do i=is_obc2,ie_obc + segment%eta(i,j) = OBC%ramp_value * segment%field(m)%buffer_dst(i,j,1) + enddo enddo - enddo + else + do j=js_obc2,je_obc + do i=is_obc2,ie_obc + segment%eta(i,j) = segment%field(m)%buffer_dst(i,j,1) + enddo + enddo + endif endif if (trim(segment%field(m)%name) == 'TEMP') then @@ -3920,6 +3947,48 @@ subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) end subroutine update_OBC_segment_data +!> Update the OBC ramp value as a function of time. +!! If called with the optional argument activate=.true., record the +!! value of Time as the beginning of the ramp period. +subroutine update_OBC_ramp(Time, OBC, activate) + type(time_type), target, intent(in) :: Time !< Current model time + type(ocean_OBC_type), pointer :: OBC !< Open boundary structure + logical, optional, intent(in) :: activate !< Specifiy whether to record the value of + !! Time as the beginning of the ramp period + + ! Local variables + real :: deltaTime, wghtA + character(len=12) :: msg + + if (.not. OBC%ramp) return ! This indicates the ramping is turned off + + ! We use the optional argument to indicate this Time should be recorded as the + ! beginning of the ramp-up period. + if (present(activate)) then + if (activate) then + OBC%ramp_start_time = Time ! Record the current time + OBC%ramping_is_activated = .true. + OBC%trunc_ramp_time = OBC%ramp_timescale ! times 3.0 for tanh + endif + endif + if (.not.OBC%ramping_is_activated) return + deltaTime = max( 0., time_type_to_real( Time - OBC%ramp_start_time ) ) + if (deltaTime >= OBC%trunc_ramp_time) then + OBC%ramp_value = 1.0 + OBC%ramp = .false. ! This turns off ramping after this call + else + wghtA = min( 1., deltaTime / OBC%ramp_timescale ) ! Linear profile in time + !wghtA = wghtA*wghtA ! Convert linear profile to parabolic profile in time + !wghtA = wghtA*wghtA*(3. - 2.*wghtA) ! Convert linear profile to cosine profile + !wghtA = 1. - ( (1. - wghtA)**2 ) ! Convert linear profile to inverted parabolic profile + !wghtA = tanh(wghtA) ! Convert linear profile to tanh + OBC%ramp_value = wghtA + endif + write(msg(1:12),'(es12.3)') OBC%ramp_value + call MOM_error(NOTE, "MOM_open_boundary: update_OBC_ramp set OBC"// & + " ramp to "//trim(msg)) +end subroutine update_OBC_ramp + !> register open boundary objects for boundary updates. subroutine register_OBC(name, param_file, Reg) character(len=32), intent(in) :: name !< OBC name used for error messages From 5a56df7d7c095a3e8f4ef2e54954bfc2e62979d9 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sat, 4 Apr 2020 08:34:56 -0400 Subject: [PATCH 145/316] +Add optional pres_scale arguments to EOS routines Added optional pres_scale arguments to various MOM_EOS.F90 routines to allow pressures to be passed with in various units for flexibility and streamlined dimensional consistency testing. Also added optional rho_scale arguments to the various int_density_dz subroutines. All answers are bitwise identical, but there are new optional arguments to public interfaces. --- src/equation_of_state/MOM_EOS.F90 | 555 +++++++++++++++-------- src/equation_of_state/MOM_EOS_Wright.F90 | 74 +-- src/equation_of_state/MOM_EOS_linear.F90 | 35 +- 3 files changed, 431 insertions(+), 233 deletions(-) diff --git a/src/equation_of_state/MOM_EOS.F90 b/src/equation_of_state/MOM_EOS.F90 index 3d0cb9abc4..d1fc2a917b 100644 --- a/src/equation_of_state/MOM_EOS.F90 +++ b/src/equation_of_state/MOM_EOS.F90 @@ -135,31 +135,36 @@ module MOM_EOS !> Calls the appropriate subroutine to calculate density of sea water for scalar inputs. !! 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, scale) +subroutine calculate_density_scalar(T, S, pressure, rho, EOS, rho_ref, scale, pres_scale) real, intent(in) :: T !< Potential temperature referenced to the surface [degC] real, intent(in) :: S !< Salinity [ppt] - real, intent(in) :: pressure !< Pressure [Pa] + real, intent(in) :: pressure !< Pressure [Pa] or [other ~> Pa] real, intent(out) :: rho !< Density (in-situ if pressure is local) [kg m-3] or [R ~> kg m-3] type(EOS_type), pointer :: EOS !< Equation of state structure real, optional, intent(in) :: rho_ref !< A reference density [kg m-3]. real, optional, intent(in) :: scale !< A multiplicative factor by which to scale density !! from kg m-3 to the desired units [R m3 kg-1] + real, optional, intent(in) :: pres_scale !< A multiplicative factor to convert pressure into Pa. + + real :: p_scale ! A factor to convert pressure to units of Pa. if (.not.associated(EOS)) call MOM_error(FATAL, & "calculate_density_scalar called with an unassociated EOS_type EOS.") + p_scale = 1.0 ; if (present(pres_scale)) p_scale = pres_scale + select case (EOS%form_of_EOS) case (EOS_LINEAR) - call calculate_density_linear(T, S, pressure, rho, & + call calculate_density_linear(T, S, p_scale*pressure, rho, & EOS%Rho_T0_S0, EOS%dRho_dT, EOS%dRho_dS, rho_ref) case (EOS_UNESCO) - call calculate_density_unesco(T, S, pressure, rho, rho_ref) + call calculate_density_unesco(T, S, p_scale*pressure, rho, rho_ref) case (EOS_WRIGHT) - call calculate_density_wright(T, S, pressure, rho, rho_ref) + call calculate_density_wright(T, S, p_scale*pressure, rho, rho_ref) case (EOS_TEOS10) - call calculate_density_teos10(T, S, pressure, rho, rho_ref) + call calculate_density_teos10(T, S, p_scale*pressure, rho, rho_ref) case (EOS_NEMO) - call calculate_density_nemo(T, S, pressure, rho, rho_ref) + call calculate_density_nemo(T, S, p_scale*pressure, rho, rho_ref) case default call MOM_error(FATAL, & "calculate_density_scalar: EOS is not valid.") @@ -173,7 +178,7 @@ end subroutine calculate_density_scalar !> Calls the appropriate subroutine to calculate the density of sea water for 1-D array inputs. !! 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, scale) +subroutine calculate_density_array(T, S, pressure, rho, start, npts, EOS, rho_ref, scale, pres_scale) real, dimension(:), intent(in) :: T !< Potential temperature referenced to the surface [degC] real, dimension(:), intent(in) :: S !< Salinity [ppt] real, dimension(:), intent(in) :: pressure !< Pressure [Pa] @@ -184,27 +189,53 @@ subroutine calculate_density_array(T, S, pressure, rho, start, npts, EOS, rho_re real, optional, intent(in) :: rho_ref !< A reference density [kg m-3]. real, optional, intent(in) :: scale !< A multiplicative factor by which to scale density !! from kg m-3 to the desired units [R m3 kg-1] + real, optional, intent(in) :: pres_scale !< A multiplicative factor to convert pressure into Pa. + + real :: p_scale ! A factor to convert pressure to units of Pa. + real, dimension(size(pressure)) :: pres ! Pressure converted to [Pa] integer :: j if (.not.associated(EOS)) call MOM_error(FATAL, & "calculate_density_array called with an unassociated EOS_type EOS.") - select case (EOS%form_of_EOS) - case (EOS_LINEAR) - call calculate_density_linear(T, S, pressure, rho, start, npts, & + p_scale = 1.0 ; if (present(pres_scale)) p_scale = pres_scale + + if (p_scale == 1.0) then + 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, rho_ref) - case (EOS_UNESCO) - 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, rho_ref) - case (EOS_TEOS10) - 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, rho_ref) - case default - call MOM_error(FATAL, & - "calculate_density_array: EOS%form_of_EOS is not valid.") - end select + case (EOS_UNESCO) + 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, rho_ref) + case (EOS_TEOS10) + 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, rho_ref) + case default + call MOM_error(FATAL, & + "calculate_density_array: EOS%form_of_EOS is not valid.") + end select + else + do j=start,start+npts-1 ; pres(j) = p_scale * pressure(j) ; enddo + select case (EOS%form_of_EOS) + case (EOS_LINEAR) + call calculate_density_linear(T, S, pres, rho, start, npts, & + EOS%Rho_T0_S0, EOS%dRho_dT, EOS%dRho_dS, rho_ref) + case (EOS_UNESCO) + call calculate_density_unesco(T, S, pres, rho, start, npts, rho_ref) + case (EOS_WRIGHT) + call calculate_density_wright(T, S, pres, rho, start, npts, rho_ref) + case (EOS_TEOS10) + call calculate_density_teos10(T, S, pres, rho, start, npts, rho_ref) + case (EOS_NEMO) + call calculate_density_nemo(T, S, pres, rho, start, npts, rho_ref) + case default + call MOM_error(FATAL, & + "calculate_density_array: EOS%form_of_EOS is not valid.") + end select + endif if (present(scale)) then ; if (scale /= 1.0) then do j=start,start+npts-1 ; rho(j) = scale * rho(j) ; enddo @@ -214,7 +245,7 @@ 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, scale) +subroutine calculate_spec_vol_scalar(T, S, pressure, specvol, EOS, spv_ref, scale, pres_scale) real, intent(in) :: T !< Potential temperature referenced to the surface [degC] real, intent(in) :: S !< Salinity [ppt] real, intent(in) :: pressure !< Pressure [Pa] @@ -223,32 +254,35 @@ subroutine calculate_spec_vol_scalar(T, S, pressure, specvol, EOS, spv_ref, scal real, optional, intent(in) :: spv_ref !< A reference specific volume [m3 kg-1]. real, optional, intent(in) :: scale !< A multiplicative factor by which to scale specific !! volume from m3 kg-1 to the desired units [kg m-3 R-1] + real, optional, intent(in) :: pres_scale !< A multiplicative factor to convert pressure into Pa. + real :: p_scale ! A factor to convert pressure to units of Pa. real :: rho if (.not.associated(EOS)) call MOM_error(FATAL, & "calculate_spec_vol_scalar called with an unassociated EOS_type EOS.") + p_scale = 1.0 ; if (present(pres_scale)) p_scale = pres_scale + 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) + call calculate_spec_vol_linear(T, S, p_scale*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) + call calculate_spec_vol_unesco(T, S, p_scale*pressure, specvol, spv_ref) case (EOS_WRIGHT) - call calculate_spec_vol_wright(T, S, pressure, specvol, spv_ref) + call calculate_spec_vol_wright(T, S, p_scale*pressure, specvol, spv_ref) case (EOS_TEOS10) - call calculate_spec_vol_teos10(T, S, pressure, specvol, spv_ref) + call calculate_spec_vol_teos10(T, S, p_scale*pressure, specvol, spv_ref) case (EOS_NEMO) - call calculate_density_nemo(T, S, pressure, rho) + call calculate_density_nemo(T, S, p_scale*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.") + call MOM_error(FATAL, "calculate_spec_vol_scalar: EOS is not valid.") end select if (present(scale)) then ; if (scale /= 1.0) then @@ -260,7 +294,7 @@ 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, scale) +subroutine calculate_spec_vol_array(T, S, pressure, specvol, start, npts, EOS, spv_ref, scale, pres_scale) real, dimension(:), intent(in) :: T !< potential temperature relative to the surface [degC]. real, dimension(:), intent(in) :: S !< salinity [ppt]. real, dimension(:), intent(in) :: pressure !< pressure [Pa]. @@ -271,34 +305,62 @@ subroutine calculate_spec_vol_array(T, S, pressure, specvol, start, npts, EOS, s real, optional, intent(in) :: spv_ref !< A reference specific volume [m3 kg-1]. real, optional, intent(in) :: scale !< A multiplicative factor by which to scale specific volume !! from m3 kg-1 to the desired units [kg m-3 R-1] + real, optional, intent(in) :: pres_scale !< A multiplicative factor to convert pressure into Pa. + real :: p_scale ! A factor to convert pressure to units of Pa. + real, dimension(size(pressure)) :: pres ! Pressure converted to [Pa] real, dimension(size(specvol)) :: rho integer :: j 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 + p_scale = 1.0 ; if (present(pres_scale)) p_scale = pres_scale + + if (p_scale == 1.0) then + 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 + else + do j=start,start+npts-1 ; pres(j) = p_scale * pressure(j) ; enddo + select case (EOS%form_of_EOS) + case (EOS_LINEAR) + call calculate_spec_vol_linear(T, S, pres, 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, pres, specvol, start, npts, spv_ref) + case (EOS_WRIGHT) + call calculate_spec_vol_wright(T, S, pres, specvol, start, npts, spv_ref) + case (EOS_TEOS10) + call calculate_spec_vol_teos10(T, S, pres, specvol, start, npts, spv_ref) + case (EOS_NEMO) + call calculate_density_nemo(T, S, pres, 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 + endif if (present(scale)) then ; if (scale /= 1.0) then ; do j=start,start+npts-1 specvol(j) = scale * specvol(j) @@ -362,7 +424,7 @@ subroutine calculate_TFreeze_array(S, pressure, T_fr, start, npts, EOS) end subroutine calculate_TFreeze_array !> Calls the appropriate subroutine to calculate density derivatives for 1-D array inputs. -subroutine calculate_density_derivs_array(T, S, pressure, drho_dT, drho_dS, start, npts, EOS, scale) +subroutine calculate_density_derivs_array(T, S, pressure, drho_dT, drho_dS, start, npts, EOS, scale, pres_scale) real, dimension(:), intent(in) :: T !< Potential temperature referenced to the surface [degC] real, dimension(:), intent(in) :: S !< Salinity [ppt] real, dimension(:), intent(in) :: pressure !< Pressure [Pa] @@ -375,27 +437,52 @@ subroutine calculate_density_derivs_array(T, S, pressure, drho_dT, drho_dS, star type(EOS_type), pointer :: EOS !< Equation of state structure real, optional, intent(in) :: scale !< A multiplicative factor by which to scale density !! from kg m-3 to the desired units [R m3 kg-1] + real, optional, intent(in) :: pres_scale !< A multiplicative factor to convert pressure into Pa. + + ! Local variables + real, dimension(size(pressure)) :: pres ! Pressure converted to [Pa] + real :: p_scale ! A factor to convert pressure to units of Pa. integer :: j if (.not.associated(EOS)) call MOM_error(FATAL, & "calculate_density_derivs called with an unassociated EOS_type EOS.") - 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) - case (EOS_UNESCO) - call calculate_density_derivs_unesco(T, S, pressure, drho_dT, drho_dS, start, npts) - case (EOS_WRIGHT) - call calculate_density_derivs_wright(T, S, pressure, drho_dT, drho_dS, start, npts) - case (EOS_TEOS10) - call calculate_density_derivs_teos10(T, S, pressure, drho_dT, drho_dS, start, npts) - case (EOS_NEMO) - call calculate_density_derivs_nemo(T, S, pressure, drho_dT, drho_dS, start, npts) - case default - call MOM_error(FATAL, & - "calculate_density_derivs_array: EOS%form_of_EOS is not valid.") - end select + p_scale = 1.0 ; if (present(pres_scale)) p_scale = pres_scale + + if (p_scale == 1.0) then + 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) + case (EOS_UNESCO) + call calculate_density_derivs_unesco(T, S, pressure, drho_dT, drho_dS, start, npts) + case (EOS_WRIGHT) + call calculate_density_derivs_wright(T, S, pressure, drho_dT, drho_dS, start, npts) + case (EOS_TEOS10) + call calculate_density_derivs_teos10(T, S, pressure, drho_dT, drho_dS, start, npts) + case (EOS_NEMO) + call calculate_density_derivs_nemo(T, S, pressure, drho_dT, drho_dS, start, npts) + case default + call MOM_error(FATAL, "calculate_density_derivs_array: EOS%form_of_EOS is not valid.") + end select + else + do j=start,start+npts-1 ; pres(j) = p_scale * pressure(j) ; enddo + select case (EOS%form_of_EOS) + case (EOS_LINEAR) + call calculate_density_derivs_linear(T, S, pres, 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, pres, drho_dT, drho_dS, start, npts) + case (EOS_WRIGHT) + call calculate_density_derivs_wright(T, S, pres, drho_dT, drho_dS, start, npts) + case (EOS_TEOS10) + call calculate_density_derivs_teos10(T, S, pres, drho_dT, drho_dS, start, npts) + case (EOS_NEMO) + call calculate_density_derivs_nemo(T, S, pres, drho_dT, drho_dS, start, npts) + case default + call MOM_error(FATAL, "calculate_density_derivs_array: EOS%form_of_EOS is not valid.") + end select + endif if (present(scale)) then ; if (scale /= 1.0) then ; do j=start,start+npts-1 drho_dT(j) = scale * drho_dT(j) @@ -406,7 +493,7 @@ end subroutine calculate_density_derivs_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, scale) +subroutine calculate_density_derivs_scalar(T, S, pressure, drho_dT, drho_dS, EOS, scale, pres_scale) real, intent(in) :: T !< Potential temperature referenced to the surface [degC] real, intent(in) :: S !< Salinity [ppt] real, intent(in) :: pressure !< Pressure [Pa] @@ -417,18 +504,23 @@ subroutine calculate_density_derivs_scalar(T, S, pressure, drho_dT, drho_dS, EOS type(EOS_type), pointer :: EOS !< Equation of state structure real, optional, intent(in) :: scale !< A multiplicative factor by which to scale density !! from kg m-3 to the desired units [R m3 kg-1] + real, optional, intent(in) :: pres_scale !< A multiplicative factor to convert pressure into Pa. + ! Local variables + real :: p_scale ! A factor to convert pressure to units of Pa. if (.not.associated(EOS)) call MOM_error(FATAL, & "calculate_density_derivs called with an unassociated EOS_type EOS.") + p_scale = 1.0 ; if (present(pres_scale)) p_scale = pres_scale + select case (EOS%form_of_EOS) case (EOS_LINEAR) - call calculate_density_derivs_linear(T, S, pressure, drho_dT, drho_dS, & + call calculate_density_derivs_linear(T, S, p_scale*pressure, drho_dT, drho_dS, & EOS%Rho_T0_S0, EOS%dRho_dT, EOS%dRho_dS) case (EOS_WRIGHT) - call calculate_density_derivs_wright(T, S, pressure, drho_dT, drho_dS) + call calculate_density_derivs_wright(T, S, p_scale*pressure, drho_dT, drho_dS) case (EOS_TEOS10) - call calculate_density_derivs_teos10(T, S, pressure, drho_dT, drho_dS) + call calculate_density_derivs_teos10(T, S, p_scale*pressure, drho_dT, drho_dS) case default call MOM_error(FATAL, & "calculate_density_derivs_scalar: EOS%form_of_EOS is not valid.") @@ -443,7 +535,7 @@ 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, scale) + drho_dS_dP, drho_dT_dP, start, npts, EOS, scale, pres_scale) real, dimension(:), intent(in) :: T !< Potential temperature referenced to the surface [degC] real, dimension(:), intent(in) :: S !< Salinity [ppt] real, dimension(:), intent(in) :: pressure !< Pressure [Pa] @@ -462,27 +554,51 @@ subroutine calculate_density_second_derivs_array(T, S, pressure, drho_dS_dS, drh type(EOS_type), pointer :: EOS !< Equation of state structure real, optional, intent(in) :: scale !< A multiplicative factor by which to scale density !! from kg m-3 to the desired units [R m3 kg-1] + real, optional, intent(in) :: pres_scale !< A multiplicative factor to convert pressure into Pa. + ! Local variables + real :: p_scale ! A factor to convert pressure to units of Pa. + real, dimension(size(pressure)) :: pres ! Pressure converted to [Pa] + real :: I_p_scale ! The inverse of the factor to convert pressure to units of Pa. integer :: j if (.not.associated(EOS)) call MOM_error(FATAL, & "calculate_density_derivs called with an unassociated EOS_type EOS.") - 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) - 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) - 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) - case default - call MOM_error(FATAL, & - "calculate_density_derivs: EOS%form_of_EOS is not valid.") - end select + p_scale = 1.0 ; if (present(pres_scale)) p_scale = pres_scale + + if (p_scale == 1.0) then + 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) + 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) + 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) + case default + call MOM_error(FATAL, "calculate_density_derivs: EOS%form_of_EOS is not valid.") + end select + else + do j=start,start+npts-1 ; pres(j) = p_scale * pressure(j) ; enddo + select case (EOS%form_of_EOS) + case (EOS_LINEAR) + call calculate_density_second_derivs_linear(T, S, pres, 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, pres, 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, pres, 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.") + end select + endif - if (present(scale)) then ; if (scale /= 1.0) then ; do j=start,start+npts-1 + if (present(scale)) then ; if (scale /= 1.0) then + ; do j=start,start+npts-1 drho_dS_dS(j) = scale * drho_dS_dS(j) drho_dS_dT(j) = scale * drho_dS_dT(j) drho_dT_dT(j) = scale * drho_dT_dT(j) @@ -490,11 +606,19 @@ subroutine calculate_density_second_derivs_array(T, S, pressure, drho_dS_dS, drh drho_dT_dP(j) = scale * drho_dT_dP(j) enddo ; endif ; endif + if (p_scale /= 1.0) then + I_p_scale = 1.0 / p_scale + do j=start,start+npts-1 + drho_dS_dP(j) = I_p_scale * drho_dS_dP(j) + drho_dT_dP(j) = I_p_scale * drho_dT_dP(j) + enddo + endif + 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, scale) + drho_dS_dP, drho_dT_dP, EOS, scale, pres_scale) real, intent(in) :: T !< Potential temperature referenced to the surface [degC] real, intent(in) :: S !< Salinity [ppt] real, intent(in) :: pressure !< Pressure [Pa] @@ -511,19 +635,25 @@ subroutine calculate_density_second_derivs_scalar(T, S, pressure, drho_dS_dS, dr type(EOS_type), pointer :: EOS !< Equation of state structure real, optional, intent(in) :: scale !< A multiplicative factor by which to scale density !! from kg m-3 to the desired units [R m3 kg-1] + real, optional, intent(in) :: pres_scale !< A multiplicative factor to convert pressure into Pa. + ! Local variables + real :: p_scale ! A factor to convert pressure to units of Pa. + real :: I_p_scale ! The inverse of the factor to convert pressure to units of Pa. if (.not.associated(EOS)) call MOM_error(FATAL, & "calculate_density_derivs called with an unassociated EOS_type EOS.") + p_scale = 1.0 ; if (present(pres_scale)) p_scale = pres_scale + select case (EOS%form_of_EOS) case (EOS_LINEAR) - call calculate_density_second_derivs_linear(T, S, pressure, drho_dS_dS, drho_dS_dT, & + call calculate_density_second_derivs_linear(T, S, p_scale*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, & + call calculate_density_second_derivs_wright(T, S, p_scale*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, & + call calculate_density_second_derivs_teos10(T, S, p_scale*pressure, drho_dS_dS, drho_dS_dT, & drho_dT_dT, drho_dS_dP, drho_dT_dP) case default call MOM_error(FATAL, & @@ -538,10 +668,16 @@ subroutine calculate_density_second_derivs_scalar(T, S, pressure, drho_dS_dS, dr drho_dT_dP = scale * drho_dT_dP endif ; endif + if (p_scale /= 1.0) then + I_p_scale = 1.0 / p_scale + drho_dS_dP = I_p_scale * drho_dS_dP + drho_dT_dP = I_p_scale * drho_dT_dP + endif + end subroutine calculate_density_second_derivs_scalar !> Calls the appropriate subroutine to calculate specific volume derivatives for an array. -subroutine calculate_specific_vol_derivs(T, S, pressure, dSV_dT, dSV_dS, start, npts, EOS, scale) +subroutine calculate_specific_vol_derivs(T, S, pressure, dSV_dT, dSV_dS, start, npts, EOS, scale, pres_scale) real, dimension(:), intent(in) :: T !< Potential temperature referenced to the surface [degC] real, dimension(:), intent(in) :: S !< Salinity [ppt] real, dimension(:), intent(in) :: pressure !< Pressure [Pa] @@ -554,14 +690,18 @@ subroutine calculate_specific_vol_derivs(T, S, pressure, dSV_dT, dSV_dS, start, type(EOS_type), pointer :: EOS !< Equation of state structure real, optional, intent(in) :: scale !< A multiplicative factor by which to scale specific volume !! from m3 kg-1 to the desired units [kg m-3 R-1] + real, optional, intent(in) :: pres_scale !< A multiplicative factor to convert pressure into Pa. ! Local variables real, dimension(size(T)) :: dRho_dT, dRho_dS, rho + real :: p_scale ! A factor to convert pressure to units of Pa. integer :: j if (.not.associated(EOS)) call MOM_error(FATAL, & "calculate_density_derivs called with an unassociated EOS_type EOS.") + p_scale = 1.0 ; if (present(pres_scale)) p_scale = pres_scale + select case (EOS%form_of_EOS) case (EOS_LINEAR) call calculate_specvol_derivs_linear(T, S, pressure, dSV_dT, dSV_dS, start, & @@ -726,9 +866,8 @@ 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. -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, & - bathyT, dz_neglect, useMassWghtInterp) +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, bathyT, dz_neglect, useMassWghtInterp, rho_scale, pres_scale) type(hor_index_type), intent(in) :: HII !< Ocean horizontal index structures for the input arrays type(hor_index_type), intent(in) :: HIO !< Ocean horizontal index structures for the output arrays real, dimension(HII%isd:HII%ied,HII%jsd:HII%jed), & @@ -739,53 +878,66 @@ subroutine int_density_dz(T, S, z_t, z_b, rho_ref, rho_0, G_e, HII, HIO, EOS, & intent(in) :: z_t !< Height at the top of the layer in depth units [Z ~> m]. real, dimension(HII%isd:HII%ied,HII%jsd:HII%jed), & intent(in) :: z_b !< Height at the bottom of the layer [Z ~> m]. - real, intent(in) :: rho_ref !< A mean density [kg m-3], that is subtracted out to - !! reduce the magnitude of each of the integrals. - real, intent(in) :: rho_0 !< A density [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 [m2 Z-1 s-2 ~> m s-2]. + real, intent(in) :: rho_ref !< A mean density [R ~> kg m-3] or [kg m-3], that is + !! subtracted out to reduce the magnitude of each of the + !! integrals. + real, intent(in) :: rho_0 !< A density [R ~> kg m-3] or [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 + !! [L2 Z-1 T-2 ~> m s-2] or [m2 Z-1 s-2 ~> m s-2]. type(EOS_type), pointer :: EOS !< Equation of state structure real, dimension(HIO%isd:HIO%ied,HIO%jsd:HIO%jed), & - intent(inout) :: dpa !< The change in the pressure anomaly across the layer [Pa]. + intent(inout) :: dpa !< The change in the pressure anomaly + !! across the layer [R L2 T-2 ~> Pa] or [Pa]. real, dimension(HIO%isd:HIO%ied,HIO%jsd:HIO%jed), & - optional, intent(inout) :: intz_dpa !< The integral through the thickness of the layer of - !! the pressure anomaly relative to the anomaly at the - !! top of the layer [Pa Z ~> Pa m]. + optional, intent(inout) :: intz_dpa !< The integral through the thickness of the + !! layer of the pressure anomaly relative to the + !! anomaly at the top of the layer [R L2 Z T-2 ~> Pa m]. real, dimension(HIO%IsdB:HIO%IedB,HIO%jsd:HIO%jed), & - optional, intent(inout) :: 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 [Pa]. + optional, intent(inout) :: 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 [R L2 T-2 ~> Pa]. real, dimension(HIO%isd:HIO%ied,HIO%JsdB:HIO%JedB), & - optional, intent(inout) :: 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 [Pa]. + optional, intent(inout) :: 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 [R L2 T-2 ~> Pa]. real, dimension(HII%isd:HII%ied,HII%jsd:HII%jed), & optional, intent(in) :: bathyT !< The depth of the bathymetry [Z ~> m]. real, optional, intent(in) :: dz_neglect !< A miniscule thickness change [Z ~> m]. logical, optional, intent(in) :: useMassWghtInterp !< If true, uses mass weighting to !! interpolate T/S for top and bottom integrals. + real, optional, intent(in) :: rho_scale !< A multiplicative factor by which to scale density + !! from kg m-3 to the desired units [R m3 kg-1 ~> 1] + real, optional, intent(in) :: pres_scale !< A multiplicative factor to convert pressure + !! into Pa [R L2 T-2 Pa-1 ~> 1]. 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, & - bathyT, dz_neglect, useMassWghtInterp) + 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, bathyT, dz_neglect, useMassWghtInterp, & + rho_scale, pres_scale) 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, & - bathyT, dz_neglect, useMassWghtInterp) + if (present(rho_scale)) then + call int_density_dz_linear(T, S, z_t, z_b, rho_ref, rho_0, G_e, HII, HIO, & + rho_scale*EOS%Rho_T0_S0, rho_scale*EOS%dRho_dT, rho_scale*EOS%dRho_dS, & + dpa, intz_dpa, intx_dpa, inty_dpa, bathyT, dz_neglect, useMassWghtInterp) + else + 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, bathyT, dz_neglect, useMassWghtInterp) + endif case (EOS_WRIGHT) - call int_density_dz_wright(T, S, z_t, z_b, rho_ref, rho_0, G_e, HII, HIO, & + 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, & - bathyT, dz_neglect, useMassWghtInterp) + bathyT, dz_neglect, useMassWghtInterp, rho_scale, pres_scale) 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, & - bathyT, dz_neglect, useMassWghtInterp) + 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, bathyT, dz_neglect, useMassWghtInterp, & + rho_scale, pres_scale) end select ; endif end subroutine int_density_dz @@ -979,7 +1131,7 @@ end subroutine EOS_use_linear !! 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, & - bathyT, dz_neglect, useMassWghtInterp) + bathyT, dz_neglect, useMassWghtInterp, rho_scale, pres_scale) 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), & @@ -990,39 +1142,49 @@ subroutine int_density_dz_generic(T, S, z_t, z_b, rho_ref, rho_0, G_e, HII, HIO, intent(in) :: z_t !< Height at the top of the layer in depth units [Z ~> m]. real, dimension(HII%isd:HII%ied,HII%jsd:HII%jed), & intent(in) :: z_b !< Height at the bottom of the layer [Z ~> m]. - real, intent(in) :: rho_ref !< A mean density [kg m-3], that is + real, intent(in) :: rho_ref !< A mean density [R ~> kg m-3] or [kg m-3], that is !! subtracted out to reduce the magnitude !! of each of the integrals. - real, intent(in) :: rho_0 !< A density [kg m-3], that is used + real, intent(in) :: rho_0 !< A density [R ~> kg m-3] or [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 [m2 Z-1 s-2 ~> m s-2]. + real, intent(in) :: G_e !< The Earth's gravitational acceleration + !! [L2 Z-1 T-2 ~> m s-2] or [m2 Z-1 s-2 ~> m s-2]. type(EOS_type), pointer :: EOS !< Equation of state structure real, dimension(HIO%isd:HIO%ied,HIO%jsd:HIO%jed), & intent(inout) :: dpa !< The change in the pressure anomaly - !! across the layer [Pa]. + !! across the layer [R L2 T-2 ~> Pa] or [Pa]. real, dimension(HIO%isd:HIO%ied,HIO%jsd:HIO%jed), & optional, intent(inout) :: intz_dpa !< The integral through the thickness of the !! layer of the pressure anomaly relative to the - !! anomaly at the top of the layer [Pa Z ~> Pa m]. + !! anomaly at the top of the layer [R L2 Z T-2 ~> Pa m]. real, dimension(HIO%IsdB:HIO%IedB,HIO%jsd:HIO%jed), & optional, intent(inout) :: 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 [Pa]. + !! layer divided by the x grid spacing [R L2 T-2 ~> Pa]. real, dimension(HIO%isd:HIO%ied,HIO%JsdB:HIO%JedB), & optional, intent(inout) :: 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 [Pa]. + !! layer divided by the y grid spacing [R L2 T-2 ~> Pa]. real, dimension(HII%isd:HII%ied,HII%jsd:HII%jed), & optional, intent(in) :: bathyT !< The depth of the bathymetry [Z ~> m]. real, optional, intent(in) :: dz_neglect !< A miniscule thickness change [Z ~> m]. 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 ! The depth averaged density anomaly [kg m-3]. - real :: w_left, w_right + real, optional, intent(in) :: rho_scale !< A multiplicative factor by which to scale density + !! from kg m-3 to the desired units [R m3 kg-1 ~> 1] + real, optional, intent(in) :: pres_scale !< A multiplicative factor to convert pressure + !! into Pa [Pa T2 R-1 L-2 ~> 1]. + ! Local variables + real :: T5(5), S5(5) ! Temperatures and salinities at five quadrature points [degC] and [ppt] + real :: p5(5) ! Pressures at five quadrature points, never rescaled from Pa [Pa] + real :: r5(5) ! Densities at five quadrature points [R ~> kg m-3] or [kg m-3] + real :: rho_anom ! The depth averaged density anomaly [R ~> kg m-3] or [kg m-3]. + real :: w_left, w_right ! Left and right weights [nondim]. real, parameter :: C1_90 = 1.0/90.0 ! Rational constants. - real :: GxRho, I_Rho + real :: GxRho ! The gravitational acceleration times density and unit conversion factors [Pa Z-1 ~> kg m-2 s-2] + real :: I_Rho ! The inverse of the Boussinesq density [R-1 ~> m3 kg-1] or [m3 kg-1] + real :: rho_ref_mks ! The reference density in MKS units, never rescaled from kg m-3 [kg m-3] real :: dz ! The layer thickness [Z ~> m]. real :: hWght ! A pressure-thickness below topography [Z ~> m]. real :: hL, hR ! Pressure-thicknesses of the columns to the left and right [Z ~> m]. @@ -1032,7 +1194,7 @@ subroutine int_density_dz_generic(T, S, z_t, z_b, rho_ref, rho_0, G_e, HII, HIO, real :: wt_L, wt_R ! The linear weights 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 gravitational acceleration times the integrals of density - ! with height at the 5 sub-column locations [Pa]. + ! with height at the 5 sub-column locations [R L2 T-2 ~> Pa] or [Pa]. logical :: do_massWeight ! Indicates whether to do mass weighting. integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, i, j, m, n, ioff, joff @@ -1046,7 +1208,8 @@ subroutine int_density_dz_generic(T, S, z_t, z_b, rho_ref, rho_0, G_e, HII, HIO, is = HIO%isc + ioff ; ie = HIO%iec + ioff js = HIO%jsc + joff ; je = HIO%jec + joff - GxRho = G_e * rho_0 + GxRho = G_e * rho_0 ; if (present(pres_scale)) GxRho = pres_scale * G_e * rho_0 + rho_ref_mks = rho_ref ; if (present(rho_scale)) rho_ref_mks = rho_ref / rho_scale I_Rho = 1.0 / rho_0 do_massWeight = .false. @@ -1064,7 +1227,7 @@ subroutine int_density_dz_generic(T, S, z_t, z_b, rho_ref, rho_0, G_e, HII, HIO, 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, rho_ref) + call calculate_density(T5, S5, p5, r5, 1, 5, EOS, rho_ref_mks, scale=rho_scale) ! 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)) @@ -1106,7 +1269,7 @@ subroutine int_density_dz_generic(T, S, z_t, z_b, rho_ref, rho_0, G_e, HII, HIO, 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, rho_ref) + call calculate_density(T5, S5, p5, r5, 1, 5, EOS, rho_ref_mks, scale=rho_scale) ! 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))) @@ -1148,7 +1311,7 @@ subroutine int_density_dz_generic(T, S, z_t, z_b, rho_ref, rho_0, G_e, HII, HIO, 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, rho_ref) + call calculate_density(T5, S5, p5, r5, 1, 5, EOS, rho_ref_mks, scale=rho_scale) ! 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))) @@ -1166,7 +1329,7 @@ end subroutine int_density_dz_generic subroutine int_density_dz_generic_plm (T_t, T_b, S_t, S_b, z_t, z_b, rho_ref, & rho_0, G_e, dz_subroundoff, bathyT, HII, HIO, EOS, dpa, & intz_dpa, intx_dpa, inty_dpa, & - useMassWghtInterp) + useMassWghtInterp, rho_scale, pres_scale) type(hor_index_type), intent(in) :: HII !< Ocean horizontal index structures for the input arrays type(hor_index_type), intent(in) :: HIO !< Ocean horizontal index structures for the output arrays real, dimension(HII%isd:HII%ied,HII%jsd:HII%jed), & @@ -1178,35 +1341,38 @@ subroutine int_density_dz_generic_plm (T_t, T_b, S_t, S_b, z_t, z_b, rho_ref, & real, dimension(HII%isd:HII%ied,HII%jsd:HII%jed), & intent(in) :: S_b !< Salinity at the cell bottom [ppt] real, dimension(HII%isd:HII%ied,HII%jsd:HII%jed), & - intent(in) :: z_t !< The geometric height at the top of the layer, - !! in depth units [Z ~> m]. + intent(in) :: z_t !< The geometric height at the top of the layer [Z ~> m]. real, dimension(HII%isd:HII%ied,HII%jsd:HII%jed), & intent(in) :: z_b !< The geometric height at the bottom of the layer [Z ~> m]. - real, intent(in) :: rho_ref !< A mean density [kg m-3], that is subtracted out to - !! reduce the magnitude of each of the integrals. - real, intent(in) :: rho_0 !< A density [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 [m2 Z-1 s-2 ~> m s-2]. + real, intent(in) :: rho_ref !< A mean density [R ~> kg m-3] or [kg m-3], that is subtracted + !! out to reduce the magnitude of each of the integrals. + real, intent(in) :: rho_0 !< A density [R ~> kg m-3] or [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 [L2 Z-1 T-2 ~> m s-2]. real, intent(in) :: dz_subroundoff !< A miniscule thickness change [Z ~> m]. real, dimension(HII%isd:HII%ied,HII%jsd:HII%jed), & intent(in) :: bathyT !< The depth of the bathymetry [Z ~> m]. type(EOS_type), pointer :: EOS !< Equation of state structure real, dimension(HIO%isd:HIO%ied,HIO%jsd:HIO%jed), & - intent(inout) :: dpa !< The change in the pressure anomaly across the layer [Pa]. + intent(inout) :: dpa !< The change in the pressure anomaly across the layer [R L2 T-2 ~> Pa]. real, dimension(HIO%isd:HIO%ied,HIO%jsd:HIO%jed), & optional, intent(inout) :: intz_dpa !< The integral through the thickness of the layer of !! the pressure anomaly relative to the anomaly at the - !! top of the layer [Pa Z]. + !! top of the layer [R L2 Z T-2 ~> Pa Z]. real, dimension(HIO%IsdB:HIO%IedB,HIO%jsd:HIO%jed), & optional, intent(inout) :: 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 [Pa]. + !! divided by the x grid spacing [R L2 T-2 ~> Pa]. real, dimension(HIO%isd:HIO%ied,HIO%JsdB:HIO%JedB), & optional, intent(inout) :: 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 [Pa]. + !! divided by the y grid spacing [R L2 T-2 ~> Pa]. logical, optional, intent(in) :: useMassWghtInterp !< If true, uses mass weighting to !! interpolate T/S for top and bottom integrals. + real, optional, intent(in) :: rho_scale !< A multiplicative factor by which to scale density + !! from kg m-3 to the desired units [R m3 kg-1 ~> 1] + real, optional, intent(in) :: pres_scale !< A multiplicative factor to convert pressure + !! into Pa [Pa T2 R-1 L-2 ~> 1]. ! 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 @@ -1221,20 +1387,24 @@ subroutine int_density_dz_generic_plm (T_t, T_b, S_t, S_b, z_t, z_b, rho_ref, & ! Local variables real :: T5((5*HIO%iscB+1):(5*(HIO%iecB+2))) ! Temperatures along a line of subgrid locations [degC]. real :: S5((5*HIO%iscB+1):(5*(HIO%iecB+2))) ! Salinities along a line of subgrid locations [ppt]. - real :: p5((5*HIO%iscB+1):(5*(HIO%iecB+2))) ! Pressures along a line of subgrid locations [Pa]. - real :: r5((5*HIO%iscB+1):(5*(HIO%iecB+2))) ! Densities along a line of subgrid locations [kg m-3]. + real :: p5((5*HIO%iscB+1):(5*(HIO%iecB+2))) ! Pressures along a line of subgrid locations, never + ! rescaled from Pa [Pa]. + real :: r5((5*HIO%iscB+1):(5*(HIO%iecB+2))) ! Densities anomalies along a line of subgrid + ! locations [R ~> kg m-3] or [kg m-3]. real :: T15((15*HIO%iscB+1):(15*(HIO%iecB+1))) ! Temperatures at an array of subgrid locations [degC]. real :: S15((15*HIO%iscB+1):(15*(HIO%iecB+1))) ! Salinities at an array of subgrid locations [ppt]. real :: p15((15*HIO%iscB+1):(15*(HIO%iecB+1))) ! Pressures at an array of subgrid locations [Pa]. - real :: r15((15*HIO%iscB+1):(15*(HIO%iecB+1))) ! Densities at an array of subgrid locations [kg m-3]. + real :: r15((15*HIO%iscB+1):(15*(HIO%iecB+1))) ! Densities at an array of subgrid locations + ! [R ~> kg m-3] or [kg m-3]. real :: wt_t(5), wt_b(5) ! Top and bottom weights [nondim]. - real :: rho_anom ! A density anomaly [kg m-3]. + real :: rho_anom ! A density anomaly [R ~> kg m-3] or [kg m-3]. real :: w_left, w_right ! Left and right weights [nondim]. real :: intz(5) ! The gravitational acceleration times the integrals of density - ! with height at the 5 sub-column locations [Pa]. + ! with height at the 5 sub-column locations [R L2 T-2 ~> Pa] or [Pa]. real, parameter :: C1_90 = 1.0/90.0 ! A rational constant [nondim]. - real :: GxRho ! Gravitational acceleration times density [kg m-1 Z-1 s-2 ~> kg m-2 s-2]. - real :: I_Rho ! The inverse of the reference density [m3 kg-1]. + real :: GxRho ! The gravitational acceleration times density and unit conversion factors [Pa Z-1 ~> kg m-2 s-2] + real :: I_Rho ! The inverse of the Boussinesq density [R-1 ~> m3 kg-1] or [m3 kg-1] + real :: rho_ref_mks ! The reference density in MKS units, never rescaled from kg m-3 [kg m-3] real :: dz(HIO%iscB:HIO%iecB+1) ! Layer thicknesses at tracer points [Z ~> m]. real :: dz_x(5,HIO%iscB:HIO%iecB) ! Layer thicknesses along an x-line of subrid locations [Z ~> m]. real :: dz_y(5,HIO%isc:HIO%iec) ! Layer thicknesses along a y-line of subrid locations [Z ~> m]. @@ -1254,7 +1424,8 @@ subroutine int_density_dz_generic_plm (T_t, T_b, S_t, S_b, z_t, z_b, rho_ref, & Isq = HIO%IscB ; Ieq = HIO%IecB ; Jsq = HIO%JscB ; Jeq = HIO%JecB - GxRho = G_e * rho_0 + GxRho = G_e * rho_0 ; if (present(pres_scale)) GxRho = pres_scale * G_e * rho_0 + rho_ref_mks = rho_ref ; if (present(rho_scale)) rho_ref_mks = rho_ref / rho_scale I_Rho = 1.0 / rho_0 massWeightToggle = 0. if (present(useMassWghtInterp)) then @@ -1280,7 +1451,7 @@ 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, rho_ref ) + call calculate_density_array(T5, S5, p5, r5, 1, (ieq-isq+2)*5, EOS, rho_ref_mks, scale=rho_scale) do i=isq,ieq+1 ; iin = i+ioff ! Use Bode's rule to estimate the pressure anomaly change. @@ -1360,7 +1531,7 @@ subroutine int_density_dz_generic_plm (T_t, T_b, S_t, S_b, z_t, z_b, rho_ref, & enddo enddo - call calculate_density(T15, S15, p15, r15, 1, 15*(ieq-isq+1), EOS, rho_ref) + call calculate_density(T15, S15, p15, r15, 1, 15*(ieq-isq+1), EOS, rho_ref_mks, scale=rho_scale) do I=Isq,Ieq ; iin = i+ioff intz(1) = dpa(i,j) ; intz(5) = dpa(i+1,j) @@ -1440,7 +1611,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, rho_ref) + r15(15*HIO%isc+1:), 1, 15*(HIO%iec-HIO%isc+1), EOS, rho_ref_mks, scale=rho_scale) do i=HIO%isc,HIO%iec ; iin = i+ioff intz(1) = dpa(i,j) ; intz(5) = dpa(i,j+1) @@ -1580,7 +1751,7 @@ end function frac_dp_at_pos !! are parabolic profiles subroutine int_density_dz_generic_ppm (T, T_t, T_b, S, S_t, S_b, & 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, rho_scale, pres_scale) type(hor_index_type), intent(in) :: HII !< Ocean horizontal index structures for the input arrays type(hor_index_type), intent(in) :: HIO !< Ocean horizontal index structures for the output arrays @@ -1600,10 +1771,10 @@ subroutine int_density_dz_generic_ppm (T, T_t, T_b, S, S_t, S_b, & intent(in) :: z_t !< Height at the top of the layer [Z ~> m]. real, dimension(HII%isd:HII%ied,HII%jsd:HII%jed), & intent(in) :: z_b !< Height at the bottom of the layer [Z ~> m]. - real, intent(in) :: rho_ref !< A mean density [kg m-3], that is subtracted out to - !! reduce the magnitude of each of the integrals. - real, intent(in) :: rho_0 !< A density [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) :: rho_ref !< A mean density [R ~> kg m-3] or [kg m-3], that is + !! subtracted out to reduce the magnitude of each of the integrals. + real, intent(in) :: rho_0 !< A density [R ~> kg m-3] or [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 [m s-2] type(EOS_type), pointer :: EOS !< Equation of state structure real, dimension(HIO%isd:HIO%ied,HIO%jsd:HIO%jed), & @@ -1620,6 +1791,10 @@ subroutine int_density_dz_generic_ppm (T, T_t, T_b, S, S_t, S_b, & optional, intent(inout) :: 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 [Pa]. + real, optional, intent(in) :: rho_scale !< A multiplicative factor by which to scale density + !! from kg m-3 to the desired units [R m3 kg-1 ~> 1] + real, optional, intent(in) :: pres_scale !< A multiplicative factor to convert pressure + !! into Pa [Pa T2 R-1 L-2 ~> 1]. ! This subroutine calculates (by numerical quadrature) integrals of ! pressure anomalies across layers, which are required for calculating the @@ -1632,12 +1807,20 @@ subroutine int_density_dz_generic_ppm (T, T_t, T_b, S, S_t, S_b, & ! vertical. The top and bottom values within each layer are provided and ! a linear interpolation is used to compute intermediate values. +!### Please note that this subroutine has not been verified to work properly! + ! Local variables - real :: T5(5), S5(5), p5(5), r5(5) - real :: rho_anom - real :: w_left, w_right, intz(5) + real :: T5(5), S5(5) + real :: p5(5) ! Pressures at five quadrature points, never rescaled from Pa [Pa] + real :: r5(5) ! Density anomalies from rho_ref at quadrature points [R ~> kg m-3] or [kg m-3] + real :: rho_anom ! The integrated density anomaly [R ~> kg m-3] or [kg m-3] + real :: w_left, w_right ! Left and right weights [nondim]. + real :: intz(5) ! The gravitational acceleration times the integrals of density + ! with height at the 5 sub-column locations [R L2 T-2 ~> Pa] or [Pa]. real, parameter :: C1_90 = 1.0/90.0 ! Rational constants. - real :: GxRho, I_Rho + real :: GxRho ! The gravitational acceleration times density and unit conversion factors [Pa Z-1 ~> kg m-2 s-2] + real :: I_Rho ! The inverse of the Boussinesq density [R-1 ~> m3 kg-1] or [m3 kg-1] + real :: rho_ref_mks ! The reference density in MKS units, never rescaled from kg m-3 [kg m-3] real :: dz real :: weight_t, weight_b real :: s0, s1, s2 ! parabola coefficients for S [ppt] @@ -1663,7 +1846,8 @@ subroutine int_density_dz_generic_ppm (T, T_t, T_b, S, S_t, S_b, & is = HIO%isc + ioff ; ie = HIO%iec + ioff js = HIO%jsc + joff ; je = HIO%jec + joff - GxRho = G_e * rho_0 + GxRho = G_e * rho_0 ; if (present(pres_scale)) GxRho = pres_scale * G_e * rho_0 + rho_ref_mks = rho_ref ; if (present(rho_scale)) rho_ref_mks = rho_ref / rho_scale I_Rho = 1.0 / rho_0 ! ============================= @@ -1691,23 +1875,18 @@ subroutine int_density_dz_generic_ppm (T, T_t, T_b, S, S_t, S_b, & T5(n) = t0 + t1 * xi + t2 * xi**2 enddo - call calculate_density(T5, S5, p5, r5, 1, 5, EOS) + call calculate_density(T5, S5, p5, r5, 1, 5, EOS, rho_ref_mks, scale=rho_scale) ! 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)) - 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 ! 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))) ) + 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))) ) - intz_dpa(i-ioff,j-joff) = 0.5 * G_e * dz**2 * ( 1000.0 - rho_ref + s0 + s1/3.0 + & - s2/6.0 ) enddo ; enddo ! end loops on j and i ! ================================================== @@ -1755,11 +1934,11 @@ subroutine int_density_dz_generic_ppm (T, T_t, T_b, S, S_t, S_b, & T5(n) = t0 + t1 * xi + t2 * xi**2 enddo - call calculate_density(T5, S5, p5, r5, 1, 5, EOS) + call calculate_density(T5, S5, p5, r5, 1, 5, EOS, rho_ref_mks, scale=rho_scale) ! 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) + 12.0*r5(3)) ) enddo intx_dpa(i-ioff,j-joff) = C1_90*(7.0*(intz(1)+intz(5)) + 32.0*(intz(2)+intz(4)) + & 12.0*intz(3)) @@ -1802,7 +1981,7 @@ 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, rho_ref_mks, scale=rho_scale ) r_node = r_node - rho_ref call compute_integral_quadratic( x, y, r_node, intx_dpa(i-ioff,j-joff) ) diff --git a/src/equation_of_state/MOM_EOS_Wright.F90 b/src/equation_of_state/MOM_EOS_Wright.F90 index bc490ca361..39d1dd26d4 100644 --- a/src/equation_of_state/MOM_EOS_Wright.F90 +++ b/src/equation_of_state/MOM_EOS_Wright.F90 @@ -408,7 +408,7 @@ end subroutine calculate_compress_wright !! 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, & - bathyT, dz_neglect, useMassWghtInterp) + bathyT, dz_neglect, useMassWghtInterp, rho_scale, pres_scale) type(hor_index_type), intent(in) :: HII !< The horizontal index type for the input arrays. type(hor_index_type), intent(in) :: HIO !< The horizontal index type for the output arrays. real, dimension(HII%isd:HII%ied,HII%jsd:HII%jed), & @@ -420,40 +420,48 @@ subroutine int_density_dz_wright(T, S, z_t, z_b, rho_ref, rho_0, G_e, HII, HIO, intent(in) :: z_t !< Height at the top of the layer in depth units [Z ~> m]. real, dimension(HII%isd:HII%ied,HII%jsd:HII%jed), & intent(in) :: z_b !< Height at the top of the layer [Z ~> m]. - real, intent(in) :: rho_ref !< A mean density [kg m-3], that is subtracted out - !! to reduce the magnitude of each of the integrals. + real, intent(in) :: rho_ref !< A mean density [R ~> kg m-3] or [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.) - real, intent(in) :: rho_0 !< Density [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 [m2 Z-1 s-2 ~> m s-2]. + real, intent(in) :: rho_0 !< Density [R ~> kg m-3] or [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 + !! [L2 Z-1 T-2 ~> m s-2] or [m2 Z-1 s-2 ~> m s-2]. real, dimension(HIO%isd:HIO%ied,HIO%jsd:HIO%jed), & intent(inout) :: dpa !< The change in the pressure anomaly across the - !! layer [Pa]. + !! layer [R L2 T-2 ~> Pa] or [Pa]. real, dimension(HIO%isd:HIO%ied,HIO%jsd:HIO%jed), & optional, intent(inout) :: intz_dpa !< The integral through the thickness of the layer !! of the pressure anomaly relative to the anomaly - !! at the top of the layer [Pa Z ~> Pa m]. + !! at the top of the layer [R Z L2 T-2 ~> Pa m]. real, dimension(HIO%IsdB:HIO%IedB,HIO%jsd:HIO%jed), & optional, intent(inout) :: 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 [Pa]. + !! layer divided by the x grid spacing [R L2 T-2 ~> Pa]. real, dimension(HIO%isd:HIO%ied,HIO%JsdB:HIO%JedB), & optional, intent(inout) :: 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 [Pa]. + !! layer divided by the y grid spacing [R L2 T-2 ~> Pa]. real, dimension(HII%isd:HII%ied,HII%jsd:HII%jed), & optional, intent(in) :: bathyT !< The depth of the bathymetry [Z ~> m]. real, optional, intent(in) :: dz_neglect !< A miniscule thickness change [Z ~> m]. logical, optional, intent(in) :: useMassWghtInterp !< If true, uses mass weighting to !! interpolate T/S for top and bottom integrals. + real, optional, intent(in) :: rho_scale !< A multiplicative factor by which to scale density + !! from kg m-3 to the desired units [R m3 kg-1 ~> 1] + real, optional, intent(in) :: pres_scale !< A multiplicative factor to convert pressure + !! into Pa [Pa T2 R-1 L-2 ~> 1]. ! Local variables real, dimension(HII%isd:HII%ied,HII%jsd:HII%jed) :: al0_2d, p0_2d, lambda_2d real :: al0, p0, lambda real :: rho_anom ! The density anomaly from rho_ref [kg m-3]. real :: eps, eps2, rem - real :: GxRho, I_Rho + real :: GxRho ! The gravitational acceleration times density and unit conversion factors [Pa Z-1 ~> kg m-2 s-2] + real :: g_Earth ! The gravitational acceleration [m2 Z-1 s-2 ~> m s-2] + real :: I_Rho ! The inverse of the Boussinesq density [m3 kg-1] + real :: rho_ref_mks ! The reference density in MKS units, never rescaled from kg m-3 [kg m-3] real :: p_ave, I_al0, I_Lzz real :: dz ! The layer thickness [Z ~> m]. real :: hWght ! A pressure-thickness below topography [Z ~> m]. @@ -464,7 +472,9 @@ subroutine int_density_dz_wright(T, S, z_t, z_b, rho_ref, rho_0, G_e, HII, HIO, real :: wt_L, wt_R ! The linear weights 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 [Pa]. + ! 5 sub-column locations [R L2 T-2 ~> Pa]. + real :: Pa_to_RL2_T2 ! A conversion factor of pressures from Pa to the output units indicated by + ! pres_scale [R L2 T-2 Pa-1 ~> 1] or [1]. 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. @@ -480,8 +490,19 @@ subroutine int_density_dz_wright(T, S, z_t, z_b, rho_ref, rho_0, G_e, HII, HIO, is = HIO%isc + ioff ; ie = HIO%iec + ioff js = HIO%jsc + joff ; je = HIO%jec + joff - GxRho = G_e * rho_0 - I_Rho = 1.0 / rho_0 + if (present(pres_scale)) then + GxRho = pres_scale * G_e * rho_0 ; g_Earth = pres_scale * G_e + Pa_to_RL2_T2 = 1.0 / pres_scale + else + GxRho = G_e * rho_0 ; g_Earth = G_e + Pa_to_RL2_T2 = 1.0 + endif + if (present(rho_scale)) then + g_Earth = g_Earth * rho_scale + rho_ref_mks = rho_ref / rho_scale ; I_Rho = rho_scale / rho_0 + else + rho_ref_mks = rho_ref ; I_Rho = 1.0 / rho_0 + endif do_massWeight = .false. if (present(useMassWghtInterp)) then ; if (useMassWghtInterp) then @@ -508,12 +529,12 @@ subroutine int_density_dz_wright(T, S, z_t, z_b, rho_ref, rho_0, G_e, HII, HIO, ! rho(j) = (pressure(j) + p0) / (lambda + al0*(pressure(j) + p0)) - rho_anom = (p0 + p_ave)*(I_Lzz*I_al0) - rho_ref + rho_anom = (p0 + p_ave)*(I_Lzz*I_al0) - rho_ref_mks rem = I_Rho * (lambda * I_al0**2) * eps2 * & (C1_3 + eps2*(0.2 + eps2*(C1_7 + C1_9*eps2))) - dpa(i-ioff,j-joff) = G_e*rho_anom*dz - 2.0*eps*rem + dpa(i-ioff,j-joff) = Pa_to_RL2_T2 * (g_Earth*rho_anom*dz - 2.0*eps*rem) if (present(intz_dpa)) & - intz_dpa(i-ioff,j-joff) = 0.5*G_e*rho_anom*dz**2 - dz*(1.0+eps)*rem + intz_dpa(i-ioff,j-joff) = Pa_to_RL2_T2 * (0.5*g_Earth*rho_anom*dz**2 - dz*(1.0+eps)*rem) enddo ; enddo if (present(intx_dpa)) then ; do j=js,je ; do I=Isq,Ieq @@ -551,13 +572,11 @@ subroutine int_density_dz_wright(T, S, z_t, z_b, rho_ref, rho_0, G_e, HII, HIO, I_Lzz = 1.0 / (p0 + (lambda * I_al0) + p_ave) eps = 0.5*GxRho*dz*I_Lzz ; eps2 = eps*eps - intz(m) = G_e*dz*((p0 + p_ave)*(I_Lzz*I_al0) - rho_ref) - 2.0*eps * & - I_Rho * (lambda * I_al0**2) * eps2 * & - (C1_3 + eps2*(0.2 + eps2*(C1_7 + C1_9*eps2))) + intz(m) = Pa_to_RL2_T2 * ( g_Earth*dz*((p0 + p_ave)*(I_Lzz*I_al0) - rho_ref_mks) - 2.0*eps * & + I_Rho * (lambda * I_al0**2) * eps2 * (C1_3 + eps2*(0.2 + eps2*(C1_7 + C1_9*eps2))) ) 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)) + intx_dpa(i-ioff,j-joff) = C1_90*(7.0*(intz(1)+intz(5)) + 32.0*(intz(2)+intz(4)) + 12.0*intz(3)) enddo ; enddo ; endif if (present(inty_dpa)) then ; do J=Jsq,Jeq ; do i=is,ie @@ -595,14 +614,13 @@ subroutine int_density_dz_wright(T, S, z_t, z_b, rho_ref, rho_0, G_e, HII, HIO, I_Lzz = 1.0 / (p0 + (lambda * I_al0) + p_ave) eps = 0.5*GxRho*dz*I_Lzz ; eps2 = eps*eps - intz(m) = G_e*dz*((p0 + p_ave)*(I_Lzz*I_al0) - rho_ref) - 2.0*eps * & - I_Rho * (lambda * I_al0**2) * eps2 * & - (C1_3 + eps2*(0.2 + eps2*(C1_7 + C1_9*eps2))) + intz(m) = Pa_to_RL2_T2 * ( g_Earth*dz*((p0 + p_ave)*(I_Lzz*I_al0) - rho_ref_mks) - 2.0*eps * & + I_Rho * (lambda * I_al0**2) * eps2 * (C1_3 + eps2*(0.2 + eps2*(C1_7 + C1_9*eps2))) ) 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)) + inty_dpa(i-ioff,j-joff) = C1_90*(7.0*(intz(1)+intz(5)) + 32.0*(intz(2)+intz(4)) + 12.0*intz(3)) enddo ; enddo ; endif + end subroutine int_density_dz_wright !> This subroutine calculates analytical and nearly-analytical integrals in diff --git a/src/equation_of_state/MOM_EOS_linear.F90 b/src/equation_of_state/MOM_EOS_linear.F90 index 55b3835681..2c19b617c6 100644 --- a/src/equation_of_state/MOM_EOS_linear.F90 +++ b/src/equation_of_state/MOM_EOS_linear.F90 @@ -339,42 +339,43 @@ subroutine int_density_dz_linear(T, S, z_t, z_b, rho_ref, rho_0_pres, G_e, HII, intent(in) :: z_t !< Height at the top of the layer in depth units [Z ~> m]. real, dimension(HII%isd:HII%ied,HII%jsd:HII%jed), & intent(in) :: z_b !< Height at the top of the layer [Z ~> m]. - real, intent(in) :: rho_ref !< A mean density [kg m-3], that is subtracted - !! out to reduce the magnitude of each of the - !! integrals. - real, intent(in) :: rho_0_pres !< A density [kg m-3], that is used to calculate + real, intent(in) :: rho_ref !< A mean density [R ~> kg m-3] or [kg m-3], that + !! is subtracted out to reduce the magnitude of + !! each of the integrals. + real, intent(in) :: rho_0_pres !< A density [R ~> kg m-3], 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. - real, intent(in) :: G_e !< The Earth's gravitational acceleration [m2 Z-1 s-2 ~> m s-2]. - real, intent(in) :: Rho_T0_S0 !< The density at T=0, S=0 [kg m-3]. + !! the equation of state. rho_0_pres is not used. + real, intent(in) :: G_e !< The Earth's gravitational acceleration + !! [L2 Z-1 T-2 ~> m s-2] or [m2 Z-1 s-2 ~> m s-2]. + real, intent(in) :: Rho_T0_S0 !< The density at T=0, S=0 [R ~> kg m-3] or [kg m-3]. real, intent(in) :: dRho_dT !< The derivative of density with temperature, - !! [kg m-3 degC-1]. + !! [R degC-1 ~> kg m-3 degC-1] or [kg m-3 degC-1]. real, intent(in) :: dRho_dS !< The derivative of density with salinity, - !! in [kg m-3 ppt-1]. + !! in [R ppt-1 ~> kg m-3 ppt-1] or [kg m-3 ppt-1]. real, dimension(HIO%isd:HIO%ied,HIO%jsd:HIO%jed), & intent(out) :: dpa !< The change in the pressure anomaly across the - !! layer [Pa]. + !! layer [R L2 T-2 ~> Pa] or [Pa]. real, dimension(HIO%isd:HIO%ied,HIO%jsd:HIO%jed), & 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 [Pa Z]. + !! at the top of the layer [R L2 Z T-2 ~> Pa Z] or [Pa Z]. real, dimension(HIO%IsdB:HIO%IedB,HIO%jsd:HIO%jed), & 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 [Pa]. + !! layer divided by the x grid spacing [R L2 T-2 ~> Pa] or [Pa]. real, dimension(HIO%isd:HIO%ied,HIO%JsdB:HIO%JedB), & 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 [Pa]. + !! layer divided by the y grid spacing [R L2 T-2 ~> Pa] or [Pa]. real, dimension(HII%isd:HII%ied,HII%jsd:HII%jed), & optional, intent(in) :: bathyT !< The depth of the bathymetry [Z ~> m]. real, optional, intent(in) :: dz_neglect !< A miniscule thickness change [Z ~> m]. logical, optional, intent(in) :: useMassWghtInterp !< If true, uses mass weighting to !! interpolate T/S for top and bottom integrals. + ! Local variables - real :: rho_anom ! The density anomaly from rho_ref [kg m-3]. - real :: raL, raR ! rho_anom to the left and right [kg m-3]. + real :: rho_anom ! The density anomaly from rho_ref [R ~> kg m-3]. + real :: raL, raR ! rho_anom to the left and right [R ~> kg m-3]. real :: dz, dzL, dzR ! Layer thicknesses [Z ~> m]. real :: hWght ! A pressure-thickness below topography [Z ~> m]. real :: hL, hR ! Pressure-thicknesses of the columns to the left and right [Z ~> m]. @@ -384,7 +385,7 @@ subroutine int_density_dz_linear(T, S, z_t, z_b, rho_ref, rho_0_pres, G_e, HII, real :: wt_L, wt_R ! The linear weights 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 [Pa]. + ! 5 sub-column locations [R L2 T-2 ~> Pa] or [Pa]. 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 From 63c451005e241f28a752a1adf6ab97b5a53d0ddd Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sat, 4 Apr 2020 09:22:58 -0400 Subject: [PATCH 146/316] +Rescaled Boussinesq pressure force calculations Rescaled the pressures in Boussinesq pressure force calculations, including changing the units of the densities passed to set_pbce_Bouss and using the new rho_scale and pres_scale arguments to the equation of state routines. All answers are bitwise identical. --- src/core/MOM_PressureForce_Montgomery.F90 | 26 +++---- src/core/MOM_PressureForce_analytic_FV.F90 | 81 +++++++++----------- src/core/MOM_PressureForce_blocked_AFV.F90 | 88 ++++++++++------------ 3 files changed, 88 insertions(+), 107 deletions(-) diff --git a/src/core/MOM_PressureForce_Montgomery.F90 b/src/core/MOM_PressureForce_Montgomery.F90 index 43de125701..e0177e35b9 100644 --- a/src/core/MOM_PressureForce_Montgomery.F90 +++ b/src/core/MOM_PressureForce_Montgomery.F90 @@ -31,7 +31,7 @@ module MOM_PressureForce_Mont type, public :: PressureForce_Mont_CS ; private logical :: tides !< If true, apply tidal momentum forcing. real :: Rho0 !< The density used in the Boussinesq - !! approximation [kg m-3]. + !! approximation [R ~> kg m-3]. real :: GFS_scale !< Ratio between gravity applied to top interface and the !! gravitational acceleration of the planet [nondim]. !! Usually this ratio is 1. @@ -401,7 +401,7 @@ subroutine PressureForce_Mont_Bouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, pbce, ! attraction and loading, in depth units [Z ~> m]. real :: p_ref(SZI_(G)) ! The pressure used to calculate the coordinate ! density [Pa] (usually 2e7 Pa = 2000 dbar). - real :: I_Rho0 ! 1/Rho0 [m3 kg-1]. + real :: I_Rho0 ! 1/Rho0 [R-1 ~> m3 kg-1]. real :: G_Rho0 ! G_Earth / Rho0 [L2 Z-1 T-2 R-1 ~> m4 s-2 kg-1]. real :: PFu_bc, PFv_bc ! The pressure gradient force due to along-layer ! compensated density gradients [L T-2 ~> m s-2] @@ -520,7 +520,7 @@ subroutine PressureForce_Mont_Bouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, pbce, do j=Jsq,Jeq+1 do i=Isq,Ieq+1 M(i,j,1) = CS%GFS_scale * (rho_star(i,j,1) * e(i,j,1)) - if (use_p_atm) M(i,j,1) = M(i,j,1) + US%m_s_to_L_T**2*p_atm(i,j) * I_Rho0 + if (use_p_atm) M(i,j,1) = M(i,j,1) + US%kg_m3_to_R*US%m_s_to_L_T**2*p_atm(i,j) * I_Rho0 enddo do k=2,nz ; do i=Isq,Ieq+1 M(i,j,k) = M(i,j,k-1) + (rho_star(i,j,k) - rho_star(i,j,k-1)) * e(i,j,K) @@ -531,7 +531,7 @@ subroutine PressureForce_Mont_Bouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, pbce, do j=Jsq,Jeq+1 do i=Isq,Ieq+1 M(i,j,1) = GV%g_prime(1) * e(i,j,1) - if (use_p_atm) M(i,j,1) = M(i,j,1) + US%m_s_to_L_T**2*p_atm(i,j) * I_Rho0 + if (use_p_atm) M(i,j,1) = M(i,j,1) + US%kg_m3_to_R*US%m_s_to_L_T**2*p_atm(i,j) * I_Rho0 enddo do k=2,nz ; do i=Isq,Ieq+1 M(i,j,k) = M(i,j,k-1) + GV%g_prime(K) * e(i,j,K) @@ -609,7 +609,7 @@ subroutine Set_pbce_Bouss(e, tv, G, GV, US, Rho0, GFS_scale, pbce, rho_star) real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1), intent(in) :: e !< Interface height [Z ~> m]. type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamic variables type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - real, intent(in) :: Rho0 !< The "Boussinesq" ocean density [kg m-3]. + real, intent(in) :: Rho0 !< The "Boussinesq" ocean density [R ~> kg m-3]. real, intent(in) :: GFS_scale !< Ratio between gravity applied to top !! interface and the gravitational acceleration of !! the planet [nondim]. Usually this ratio is 1. @@ -623,13 +623,13 @@ subroutine Set_pbce_Bouss(e, tv, G, GV, US, Rho0, GFS_scale, pbce, rho_star) ! Local variables real :: Ihtot(SZI_(G)) ! The inverse of the sum of the layer thicknesses [H-1 ~> m-1 or m2 kg-1]. - real :: press(SZI_(G)) ! Interface pressure [Pa]. + real :: press(SZI_(G)) ! Interface pressure [R L2 T-2 ~> Pa]. real :: T_int(SZI_(G)) ! Interface temperature [degC]. real :: S_int(SZI_(G)) ! Interface salinity [ppt]. real :: dR_dT(SZI_(G)) ! Partial derivative of density with temperature [R degC-1 ~> kg m-3 degC-1]. real :: dR_dS(SZI_(G)) ! Partial derivative of density with salinity [R ppt-1 ~> kg m-3 ppt-1]. real :: rho_in_situ(SZI_(G)) ! In-situ density at the top of a layer [R ~> kg m-3]. - real :: G_Rho0 ! A scaled version of g_Earth / Rho0 [L2 m3 Z-1 T-2 kg-1 ~> m4 s-2 kg-1] + real :: G_Rho0 ! A scaled version of g_Earth / Rho0 [L2 Z-1 T-2 R-1 ~> m4 s-2 kg-1] real :: Rho0xG ! g_Earth * Rho0 [kg s-2 m-1 Z-1 ~> kg s-2 m-2] logical :: use_EOS ! If true, density is calculated from T & S using ! an equation of state. @@ -639,7 +639,7 @@ subroutine Set_pbce_Bouss(e, tv, G, GV, US, Rho0, GFS_scale, pbce, rho_star) Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB ; nz = G%ke - Rho0xG = Rho0*US%L_T_to_m_s**2 * GV%g_Earth + Rho0xG = Rho0 * GV%g_Earth G_Rho0 = GV%g_Earth / GV%Rho0 use_EOS = associated(tv%eqn_of_state) z_neglect = GV%H_subroundoff*GV%H_to_Z @@ -664,8 +664,8 @@ subroutine Set_pbce_Bouss(e, tv, G, GV, US, Rho0, GFS_scale, pbce, rho_star) Ihtot(i) = GV%H_to_Z / ((e(i,j,1)-e(i,j,nz+1)) + z_neglect) press(i) = -Rho0xG*e(i,j,1) enddo - call calculate_density(tv%T(:,j,1), tv%S(:,j,1), press, rho_in_situ, & - Isq, Ieq-Isq+2, tv%eqn_of_state, scale=US%kg_m3_to_R) + call calculate_density(tv%T(:,j,1), tv%S(:,j,1), press, rho_in_situ, Isq, Ieq-Isq+2, & + tv%eqn_of_state, scale=US%kg_m3_to_R, pres_scale=US%R_to_kg_m3*US%L_T_to_m_s**2) do i=Isq,Ieq+1 pbce(i,j,1) = G_Rho0*(GFS_scale * rho_in_situ(i)) * GV%H_to_Z enddo @@ -675,8 +675,8 @@ subroutine Set_pbce_Bouss(e, tv, G, GV, US, Rho0, GFS_scale, pbce, rho_star) T_int(i) = 0.5*(tv%T(i,j,k-1)+tv%T(i,j,k)) S_int(i) = 0.5*(tv%S(i,j,k-1)+tv%S(i,j,k)) enddo - call calculate_density_derivs(T_int, S_int, press, dR_dT, dR_dS, & - Isq, Ieq-Isq+2, tv%eqn_of_state, scale=US%kg_m3_to_R) + call calculate_density_derivs(T_int, S_int, press, dR_dT, dR_dS, Isq, Ieq-Isq+2, & + tv%eqn_of_state, scale=US%kg_m3_to_R, pres_scale=US%R_to_kg_m3*US%L_T_to_m_s**2) do i=Isq,Ieq+1 pbce(i,j,k) = pbce(i,j,k-1) + G_Rho0 * & ((e(i,j,K) - e(i,j,nz+1)) * Ihtot(i)) * & @@ -851,7 +851,7 @@ subroutine PressureForce_Mont_init(Time, G, GV, US, param_file, diag, CS, tides_ "calculate accelerations and the mass for conservation "//& "properties, or with BOUSSINSEQ false to convert some "//& "parameters from vertical units of m to kg m-2.", & - units="kg m-3", default=1035.0) + units="kg m-3", default=1035.0, scale=US%R_to_kg_m3) call get_param(param_file, mdl, "TIDES", CS%tides, & "If true, apply tidal momentum forcing.", default=.false.) call get_param(param_file, mdl, "USE_EOS", use_EOS, default=.true., & diff --git a/src/core/MOM_PressureForce_analytic_FV.F90 b/src/core/MOM_PressureForce_analytic_FV.F90 index 75a2dfad7f..d0a6932810 100644 --- a/src/core/MOM_PressureForce_analytic_FV.F90 +++ b/src/core/MOM_PressureForce_analytic_FV.F90 @@ -36,7 +36,7 @@ module MOM_PressureForce_AFV type, public :: PressureForce_AFV_CS ; private logical :: tides !< If true, apply tidal momentum forcing. real :: Rho0 !< The density used in the Boussinesq - !! approximation [kg m-3]. + !! approximation [R ~> kg m-3]. real :: GFS_scale !< A scaling of the surface pressure gradients to !! allow the use of a reduced gravity model [nondim]. type(time_type), pointer :: Time !< A pointer to the ocean model's clock. @@ -77,7 +77,7 @@ subroutine PressureForce_AFV(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm, pbc !! or atmosphere-ocean interface [Pa]. real, dimension(SZI_(G),SZJ_(G),SZK_(G)), optional, intent(out) :: pbce !< The baroclinic pressure !! anomaly in each layer due to eta anomalies - !! [m2 s-2 H-1 ~> m s-2 or m4 s-2 kg-1]. + !! [L2 T-2 H-1 ~> m s-2 or m4 s-2 kg-1]. real, dimension(SZI_(G),SZJ_(G)), optional, intent(out) :: eta !< The bottom mass used to !! calculate PFu and PFv [H ~> m or kg m-2], with any tidal !! contributions or compressibility compensation. @@ -113,7 +113,7 @@ subroutine PressureForce_AFV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p !! or atmosphere-ocean interface [Pa]. real, dimension(SZI_(G),SZJ_(G),SZK_(G)), optional, intent(out) :: pbce !< The baroclinic pressure !! anomaly in each layer due to eta anomalies - !! [m2 s-2 H-1 ~> m s-2 or m4 s-2 kg-1]. + !! [L2 T-2 H-1 ~> m s-2 or m4 s-2 kg-1]. real, dimension(SZI_(G),SZJ_(G)), optional, intent(out) :: eta !< The bottom mass used to !! calculate PFu and PFv [H ~> m or kg m-2], with any tidal !! contributions or compressibility compensation. @@ -194,7 +194,7 @@ subroutine PressureForce_AFV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p 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 + alpha_ref = 1.0/(US%R_to_kg_m3*CS%Rho0) g_Earth_z = US%L_T_to_m_s**2 * GV%g_Earth I_gEarth = 1.0 / g_Earth_z @@ -456,7 +456,7 @@ subroutine PressureForce_AFV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_at !! or atmosphere-ocean interface [Pa]. real, dimension(SZI_(G),SZJ_(G),SZK_(G)), optional, intent(out) :: pbce !< The baroclinic pressure !! anomaly in each layer due to eta anomalies - !! [m2 s-2 H-1 ~> m s-2 or m4 s-2 kg-1]. + !! [L2 T-2 H-1 ~> m s-2 or m4 s-2 kg-1]. real, dimension(SZI_(G),SZJ_(G)), optional, intent(out) :: eta !< The bottom mass used to !! calculate PFu and PFv [H ~> m or kg m-2], with any !! tidal contributions or compressibility compensation. @@ -471,22 +471,21 @@ subroutine PressureForce_AFV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_at Rho_cv_BL ! The coordinate potential density in the deepest variable ! density near-surface layer [R ~> kg m-3]. real, dimension(SZI_(G),SZJ_(G)) :: & - dz_geo, & ! The change in geopotential thickness through a layer times some dimensional - ! rescaling factors [kg m-1 R-1 s-2 ~> m2 s-2]. + dz_geo, & ! The change in geopotential thickness through a layer [L2 T-2 ~> m2 s-2]. pa, & ! The pressure anomaly (i.e. pressure + g*RHO_0*e) at the - ! the interface atop a layer [Pa]. + ! the interface atop a layer [R L2 T-2 ~> Pa]. dpa, & ! The change in pressure anomaly between the top and bottom - ! of a layer [Pa]. + ! of a layer [R L2 T-2 ~> Pa]. intz_dpa ! The vertical integral in depth of the pressure anomaly less the - ! pressure anomaly at the top of the layer [H Pa ~> m Pa or kg m-2 Pa]. + ! pressure anomaly at the top of the layer [H R L2 T-2 ~> m Pa or kg m-2 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 [Pa]. - intx_dpa ! The change in intx_pa through a layer [Pa]. + ! atop a layer, divided by the grid spacing [R L2 T-2 ~> Pa]. + intx_dpa ! The change in intx_pa through a layer [R L2 T-2 ~> 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 [Pa]. - inty_dpa ! The change in inty_pa through a layer [Pa]. + ! interface atop a layer, divided by the grid spacing [R L2 T-2 ~> Pa]. + inty_dpa ! The change in inty_pa through a layer [R L2 T-2 ~> Pa]. real, dimension(SZI_(G),SZJ_(G),SZK_(G)), target :: & T_tmp, & ! Temporary array of temperatures where layers that are lighter @@ -502,12 +501,9 @@ subroutine PressureForce_AFV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_at real :: p0(SZI_(G)) ! An array of zeros to use for pressure [Pa]. real :: h_neglect ! A thickness that is so small it is usually lost ! in roundoff and can be neglected [H ~> m]. - real :: g_Earth_mks_z ! A scaled version of g_Earth [m2 Z-1 s-2 ~> m s-2]. - real :: g_Earth_z_geo ! Another scaled version of g_Earth [R m5 kg-1 Z-1 s-2 ~> m s-2]. - real :: I_Rho0 ! 1/Rho0 times unit scaling factors [L2 m kg-1 s2 T-2 ~> m3 kg-1]. + real :: I_Rho0 ! The inverse of the Boussinesq reference density [R-1 ~> m3 kg-1]. real :: G_Rho0 ! G_Earth / Rho0 in [L2 Z-1 T-2 R-1 ~> m4 s-2 kg-1]. - real :: Rho_ref ! The reference density [R ~> kg m-3]. - real :: Rho_ref_mks ! The reference density in mks units [kg m-3]. + real :: rho_ref ! The reference density [R ~> kg m-3]. real :: dz_neglect ! A minimal thickness [Z ~> m], like e. logical :: use_p_atm ! If true, use the atmospheric pressure. logical :: use_ALE ! If true, use an ALE pressure reconstruction. @@ -534,12 +530,9 @@ subroutine PressureForce_AFV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_at h_neglect = GV%H_subroundoff dz_neglect = GV%H_subroundoff * GV%H_to_Z - I_Rho0 = US%m_s_to_L_T**2 / (US%R_to_kg_m3*GV%Rho0) - g_Earth_mks_z = US%L_T_to_m_s**2 * GV%g_Earth - g_Earth_z_geo = US%R_to_kg_m3*US%L_T_to_m_s**2 * GV%g_Earth + I_Rho0 = 1.0 / GV%Rho0 G_Rho0 = GV%g_Earth / GV%Rho0 - rho_ref_mks = CS%Rho0 - rho_ref = rho_ref_mks*US%kg_m3_to_R + rho_ref = CS%Rho0 if (CS%tides) then ! Determine the surface height anomaly for calculating self attraction @@ -651,12 +644,12 @@ subroutine PressureForce_AFV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_at 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*g_Earth_z_geo)*e(i,j,1) + p_atm(i,j) + pa(i,j) = (rho_ref*GV%g_Earth)*e(i,j,1) + US%kg_m3_to_R*US%m_s_to_L_T**2 * p_atm(i,j) enddo ; enddo else !$OMP parallel do default(shared) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - pa(i,j) = (rho_ref*g_Earth_z_geo)*e(i,j,1) + pa(i,j) = (rho_ref*GV%g_Earth)*e(i,j,1) enddo ; enddo endif !$OMP parallel do default(shared) @@ -680,24 +673,21 @@ subroutine PressureForce_AFV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_at ! 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_mks, CS%Rho0, g_Earth_mks_z, & - dz_neglect, G%bathyT, G%HI, G%HI, & - tv%eqn_of_state, dpa, intz_dpa, intx_dpa, inty_dpa, & - useMassWghtInterp = CS%useMassWghtInterp) + 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, & + rho_scale=US%kg_m3_to_R, pres_scale=US%R_to_kg_m3*US%L_T_to_m_s**2) 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_mks, CS%Rho0, g_Earth_mks_z, & - G%HI, G%HI, tv%eqn_of_state, dpa, intz_dpa, & - intx_dpa, inty_dpa) + 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, & + rho_scale=US%kg_m3_to_R, pres_scale=US%R_to_kg_m3*US%L_T_to_m_s**2) endif else call int_density_dz(tv_tmp%T(:,:,k), tv_tmp%S(:,:,k), e(:,:,K), e(:,:,K+1), & - rho_ref_mks, CS%Rho0, g_Earth_mks_z, G%HI, G%HI, tv%eqn_of_state, & - dpa, intz_dpa, intx_dpa, inty_dpa, & - G%bathyT, dz_neglect, CS%useMassWghtInterp) + 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, & + rho_scale=US%kg_m3_to_R, pres_scale=US%R_to_kg_m3*US%L_T_to_m_s**2) endif !$OMP parallel do default(shared) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 @@ -706,7 +696,7 @@ subroutine PressureForce_AFV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_at else !$OMP parallel do default(shared) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - dz_geo(i,j) = g_Earth_z_geo * GV%H_to_Z*h(i,j,k) + dz_geo(i,j) = GV%g_Earth * GV%H_to_Z*h(i,j,k) dpa(i,j) = (GV%Rlay(k) - rho_ref) * dz_geo(i,j) intz_dpa(i,j) = 0.5*(GV%Rlay(k) - rho_ref) * dz_geo(i,j)*h(i,j,k) enddo ; enddo @@ -767,15 +757,14 @@ subroutine PressureForce_AFV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_at 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) + ! 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%Z_to_H + e_tidal(i,j)*GV%Z_to_H enddo ; enddo else - !$OMP parallel do default(shared) + !$OMP parallel do default(shared) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 eta(i,j) = e(i,j,1)*GV%Z_to_H enddo ; enddo @@ -819,7 +808,7 @@ subroutine PressureForce_AFV_init(Time, G, GV, US, param_file, diag, CS, tides_C "calculate accelerations and the mass for conservation "//& "properties, or with BOUSSINSEQ false to convert some "//& "parameters from vertical units of m to kg m-2.", & - units="kg m-3", default=1035.0) + units="kg m-3", default=1035.0, scale=US%kg_m3_to_R) 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, & diff --git a/src/core/MOM_PressureForce_blocked_AFV.F90 b/src/core/MOM_PressureForce_blocked_AFV.F90 index faa7912f1e..60e1330aa6 100644 --- a/src/core/MOM_PressureForce_blocked_AFV.F90 +++ b/src/core/MOM_PressureForce_blocked_AFV.F90 @@ -36,7 +36,7 @@ module MOM_PressureForce_blk_AFV type, public :: PressureForce_blk_AFV_CS ; private logical :: tides !< If true, apply tidal momentum forcing. real :: Rho0 !< The density used in the Boussinesq - !! approximation [kg m-3]. + !! approximation [R ~> kg m-3]. real :: GFS_scale !< A scaling of the surface pressure gradients to !! allow the use of a reduced gravity model [nondim]. type(time_type), pointer :: Time !< A pointer to the ocean model's clock. @@ -77,7 +77,7 @@ subroutine PressureForce_blk_AFV(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm, !! or atmosphere-ocean interface [Pa]. real, dimension(SZI_(G),SZJ_(G),SZK_(G)), optional, intent(out) :: pbce !< The baroclinic pressure !! anomaly in each layer due to eta anomalies - !! [m2 s-2 H-1 ~> m s-2 or m4 s-2 kg-1]. + !! [L2 T-2 H-1 ~> m s-2 or m4 s-2 kg-1]. real, dimension(SZI_(G),SZJ_(G)), optional, intent(out) :: eta !< The bottom mass used to !! calculate PFu and PFv [H ~> m or kg m-2], with any tidal !! contributions or compressibility compensation. @@ -112,7 +112,7 @@ subroutine PressureForce_blk_AFV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, !! or atmosphere-ocean interface [Pa]. real, dimension(SZI_(G),SZJ_(G),SZK_(G)), optional, intent(out) :: pbce !< The baroclinic pressure !! anomaly in each layer due to eta anomalies - !! [m2 s-2 H-1 ~> m s-2 or m4 s-2 kg-1]. + !! [L2 T-2 H-1 ~> m s-2 or m4 s-2 kg-1]. real, dimension(SZI_(G),SZJ_(G)), optional, intent(out) :: eta !< The bottom mass used to !! calculate PFu and PFv [H ~> m or kg m-2], with any tidal !! contributions or compressibility compensation. @@ -190,7 +190,7 @@ subroutine PressureForce_blk_AFV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, use_EOS = associated(tv%eqn_of_state) dp_neglect = GV%H_to_Pa * GV%H_subroundoff - alpha_ref = 1.0/CS%Rho0 + alpha_ref = 1.0/(US%R_to_kg_m3*CS%Rho0) g_Earth_z = US%L_T_to_m_s**2 * GV%g_Earth I_gEarth = 1.0 / g_Earth_z @@ -437,7 +437,7 @@ subroutine PressureForce_blk_AFV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, !! or atmosphere-ocean interface [Pa]. real, dimension(SZI_(G),SZJ_(G),SZK_(G)), optional, intent(out) :: pbce !< The baroclinic pressure !! anomaly in each layer due to eta anomalies - !! [m2 s-2 H-1 ~> m s-2 or m4 s-2 kg-1]. + !! [L2 T-2 H-1 ~> m s-2 or m4 s-2 kg-1]. real, dimension(SZI_(G),SZJ_(G)), optional, intent(out) :: eta !< The bottom mass used to !! calculate PFu and PFv [H ~> m or kg m-2], with any tidal !! contributions or compressibility compensation. @@ -452,22 +452,21 @@ subroutine PressureForce_blk_AFV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, Rho_cv_BL ! The coordinate potential density in the deepest variable ! density near-surface layer [R ~> 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 times some dimensional - ! rescaling factors [kg m-1 R-1 s-2 ~> m2 s-2]. + dz_bk, & ! The change in geopotential thickness through a layer [L2 T-2 ~> m2 s-2]. pa_bk, & ! The pressure anomaly (i.e. pressure + g*RHO_0*e) at the - ! the interface atop a layer [Pa]. + ! the interface atop a layer [R L2 T-2 ~> Pa]. dpa_bk, & ! The change in pressure anomaly between the top and bottom - ! of a layer [Pa]. + ! of a layer [R L2 T-2 ~> Pa]. intz_dpa_bk ! The vertical integral in depth of the pressure anomaly less the - ! pressure anomaly at the top of the layer [H Pa ~> m Pa or kg m-2 Pa]. + ! pressure anomaly at the top of the layer [H R L2 T-2 ~> m Pa or kg m-2 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 [Pa]. - intx_dpa_bk ! The change in intx_pa through a layer [Pa]. + ! atop a layer, divided by the grid spacing [R L2 T-2 ~> Pa]. + intx_dpa_bk ! The change in intx_pa through a layer [R L2 T-2 ~> 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 [Pa]. - inty_dpa_bk ! The change in inty_pa through a layer [Pa]. + ! interface atop a layer, divided by the grid spacing [R L2 T-2 ~> Pa]. + inty_dpa_bk ! The change in inty_pa through a layer [R L2 T-2 ~> Pa]. real, dimension(SZI_(G),SZJ_(G),SZK_(G)), target :: & T_tmp, & ! Temporary array of temperatures where layers that are lighter @@ -483,12 +482,9 @@ subroutine PressureForce_blk_AFV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, real :: p0(SZI_(G)) ! An array of zeros to use for pressure [Pa]. real :: h_neglect ! A thickness that is so small it is usually lost ! in roundoff and can be neglected [H ~> m or kg m-2]. - real :: I_Rho0 ! 1/Rho0 times unit scaling factors [L2 m kg-1 s2 T-2 ~> m3 kg-1]. - real :: g_Earth_mks_z ! A scaled version of g_Earth [m2 Z-1 s-2 ~> m s-2]. - real :: g_Earth_z_geo ! Another scaled version of g_Earth [R m5 kg-1 Z-1 s-2 ~> m s-2]. + real :: I_Rho0 ! The inverse of the Boussinesq reference density [R-1 ~> m3 kg-1]. real :: G_Rho0 ! G_Earth / Rho0 [L2 Z-1 T-2 R-1 ~> m4 s-2 kg-1]. - real :: Rho_ref ! The reference density [R-1 ~> kg m-3]. - real :: Rho_ref_mks ! The reference density in mks units [kg m-3]. + real :: rho_ref ! The reference density [R ~> kg m-3]. real :: dz_neglect ! A minimal thickness [Z ~> m], like e. logical :: use_p_atm ! If true, use the atmospheric pressure. logical :: use_ALE ! If true, use an ALE pressure reconstruction. @@ -518,12 +514,9 @@ subroutine PressureForce_blk_AFV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, h_neglect = GV%H_subroundoff dz_neglect = GV%H_subroundoff * GV%H_to_Z - I_Rho0 = US%m_s_to_L_T**2 / (US%R_to_kg_m3*GV%Rho0) - g_Earth_mks_z = US%L_T_to_m_s**2 * GV%g_Earth - g_Earth_z_geo = US%R_to_kg_m3*US%L_T_to_m_s**2 * GV%g_Earth + I_Rho0 = 1.0 / GV%Rho0 G_Rho0 = GV%g_Earth / GV%Rho0 - Rho_ref_mks = CS%Rho0 - Rho_ref = Rho_ref_mks*US%kg_m3_to_R + rho_ref = CS%Rho0 if (CS%tides) then ! Determine the surface height anomaly for calculating self attraction @@ -629,9 +622,9 @@ subroutine PressureForce_blk_AFV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, endif endif -!$OMP parallel do default(none) shared(use_p_atm,Rho_ref,Rho_ref_mks,G,GV,e,p_atm,nz,use_EOS,& -!$OMP use_ALE,T_t,T_b,S_t,S_b,CS,tv,tv_tmp,g_Earth_z_geo, & -!$OMP g_Earth_mks_z,h,PFu,I_Rho0,h_neglect,dz_neglect,PFv,dM)& +!$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, & @@ -650,12 +643,12 @@ subroutine PressureForce_blk_AFV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, 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*g_Earth_z_geo)*e(i,j,1) + p_atm(i,j) + pa_bk(ib,jb) = (Rho_ref*GV%g_Earth)*e(i,j,1) + US%kg_m3_to_R*US%m_s_to_L_T**2*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*g_Earth_z_geo)*e(i,j,1) + 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 @@ -677,24 +670,24 @@ subroutine PressureForce_blk_AFV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, ! 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_mks, CS%Rho0, g_Earth_mks_z, & - 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) + 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, & + rho_scale=US%kg_m3_to_R, pres_scale=US%R_to_kg_m3*US%L_T_to_m_s**2) 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_mks, CS%Rho0, g_Earth_mks_z, & - G%HI, G%Block(n), tv%eqn_of_state, dpa_bk, intz_dpa_bk, & - intx_dpa_bk, inty_dpa_bk) + 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, & + rho_scale=US%kg_m3_to_R, pres_scale=US%R_to_kg_m3*US%L_T_to_m_s**2) endif else call int_density_dz(tv_tmp%T(:,:,k), tv_tmp%S(:,:,k), e(:,:,K), e(:,:,K+1), & - Rho_ref_mks, CS%Rho0, g_Earth_mks_z, G%HI, G%Block(n), tv%eqn_of_state, & + 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) + G%bathyT, dz_neglect, CS%useMassWghtInterp, & + rho_scale=US%kg_m3_to_R, pres_scale=US%R_to_kg_m3*US%L_T_to_m_s**2) 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%Z_to_H @@ -702,7 +695,7 @@ subroutine PressureForce_blk_AFV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, 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) = g_Earth_z_geo*GV%H_to_Z*h(i,j,k) + dz_bk(ib,jb) = GV%g_Earth*GV%H_to_Z*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 @@ -759,15 +752,14 @@ subroutine PressureForce_blk_AFV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, 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) + ! 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%Z_to_H + e_tidal(i,j)*GV%Z_to_H enddo ; enddo else - !$OMP parallel do default(shared) + !$OMP parallel do default(shared) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 eta(i,j) = e(i,j,1)*GV%Z_to_H enddo ; enddo @@ -811,7 +803,7 @@ subroutine PressureForce_blk_AFV_init(Time, G, GV, US, param_file, diag, CS, tid "calculate accelerations and the mass for conservation "//& "properties, or with BOUSSINSEQ false to convert some "//& "parameters from vertical units of m to kg m-2.", & - units="kg m-3", default=1035.0) + units="kg m-3", default=1035.0, scale=US%kg_m3_to_R) 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, & From 7632abe2d78f74040dd7b75965ab4b4f8de92a50 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sun, 5 Apr 2020 09:06:13 -0400 Subject: [PATCH 147/316] +Add optional SV_scale arg to int_specific_vol_dp Optionally rescale the units of the specific volume integrals. Added new optional SV_scale and pres_scale arguments to int_specific_vol_dp, int_spec_vol_dp_generic, and int_spec_vol_dp_Wright. All answers are bitwise identical, but there are new optional arguments to public interfaces. --- src/equation_of_state/MOM_EOS.F90 | 219 ++++++++++++++--------- src/equation_of_state/MOM_EOS_Wright.F90 | 70 +++++--- src/equation_of_state/MOM_EOS_linear.F90 | 50 +++--- 3 files changed, 202 insertions(+), 137 deletions(-) diff --git a/src/equation_of_state/MOM_EOS.F90 b/src/equation_of_state/MOM_EOS.F90 index d1fc2a917b..5603246ace 100644 --- a/src/equation_of_state/MOM_EOS.F90 +++ b/src/equation_of_state/MOM_EOS.F90 @@ -800,43 +800,50 @@ end subroutine calculate_compress_scalar !! 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, & - bathyP, dP_tiny, useMassWghtInterp) + bathyP, dP_tiny, useMassWghtInterp, SV_scale, pres_scale) type(hor_index_type), intent(in) :: HI !< The horizontal index structure real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & intent(in) :: T !< Potential temperature referenced to the surface [degC] real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & intent(in) :: S !< Salinity [ppt] real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & - intent(in) :: p_t !< Pressure at the top of the layer [Pa]. + intent(in) :: p_t !< Pressure at the top of the layer [R L2 T-2 ~> Pa] or [Pa]. real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & - intent(in) :: p_b !< Pressure at the bottom of the layer [Pa]. + intent(in) :: p_b !< Pressure at the bottom of the layer [R L2 T-2 ~> Pa] or [Pa]. real, intent(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 + !! to reduce the magnitude of each of the integrals [R-1 ~> m3 kg-1]. + !! The calculation is mathematically identical with different values of !! alpha_ref, but this reduces the effects of roundoff. type(EOS_type), pointer :: EOS !< Equation of state structure real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & intent(inout) :: dza !< The change in the geopotential anomaly across - !! the layer [m2 s-2]. + !! the layer [T-2 ~> m2 s-2] or [m2 s-2]. real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & optional, intent(inout) :: intp_dza !< The integral in pressure through the layer of the !! geopotential anomaly relative to the anomaly at the bottom of the - !! layer [Pa m2 s-2]. + !! layer [R L4 T-4 ~> Pa m2 s-2] or [Pa m2 s-2]. real, dimension(HI%IsdB:HI%IedB,HI%jsd:HI%jed), & optional, intent(inout) :: 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 [m2 s-2]. + !! the x grid spacing [L2 T-2 ~> m2 s-2] or [m2 s-2]. real, dimension(HI%isd:HI%ied,HI%JsdB:HI%JedB), & optional, intent(inout) :: 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 [m2 s-2]. + !! the y grid spacing [L2 T-2 ~> m2 s-2] or [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 [Pa] + optional, intent(in) :: bathyP !< The pressure at the bathymetry [R L2 T-2 ~> Pa] or [Pa] real, optional, intent(in) :: dP_tiny !< A miniscule pressure change with - !! the same units as p_t (Pa?) + !! the same units as p_t [R L2 T-2 ~> Pa] or [Pa] logical, optional, intent(in) :: useMassWghtInterp !< If true, uses mass weighting !! to interpolate T/S for top and bottom integrals. + real, optional, intent(in) :: SV_scale !< A multiplicative factor by which to scale specific + !! volume from m3 kg-1 to the desired units [kg m-3 R-1 ~> 1] + real, optional, intent(in) :: pres_scale !< A multiplicative factor to convert pressure + !! into Pa [Pa T2 R-1 L-2 ~> 1]. + + ! Local variables + real :: rho_scale ! A scaling factor for densities from kg m-3 to R [R m3 kg-1 ~> 1] if (.not.associated(EOS)) call MOM_error(FATAL, & "int_specific_vol_dp called with an unassociated EOS_type EOS.") @@ -844,21 +851,29 @@ subroutine int_specific_vol_dp(T, S, p_t, p_b, alpha_ref, HI, 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, & - bathyP, dP_tiny, useMassWghtInterp) + bathyP, dP_tiny, useMassWghtInterp, SV_scale, pres_scale) 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, & + if (present(SV_scale)) then + rho_scale = 1.0 / SV_scale + call int_spec_vol_dp_linear(T, S, p_t, p_b, alpha_ref, HI, rho_scale*EOS%Rho_T0_S0, & + rho_scale*EOS%dRho_dT, rho_scale*EOS%dRho_dS, dza, intp_dza, & + intx_dza, inty_dza, halo_size, & + bathyP, dP_tiny, useMassWghtInterp) + else + 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, & bathyP, dP_tiny, useMassWghtInterp) + endif 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, & - bathyP, dP_tiny, useMassWghtInterp) + bathyP, dP_tiny, useMassWghtInterp, SV_scale, pres_scale) 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, & - bathyP, dP_tiny, useMassWghtInterp) + bathyP, dP_tiny, useMassWghtInterp, SV_scale, pres_scale) end select ; endif end subroutine int_specific_vol_dp @@ -1176,7 +1191,7 @@ subroutine int_density_dz_generic(T, S, z_t, z_b, rho_ref, rho_0, G_e, HII, HIO, real, optional, intent(in) :: pres_scale !< A multiplicative factor to convert pressure !! into Pa [Pa T2 R-1 L-2 ~> 1]. ! Local variables - real :: T5(5), S5(5) ! Temperatures and salinities at five quadrature points [degC] and [ppt] + real :: T5(5), S5(5) ! Temperatures and salinities at five quadrature points [degC] and [ppt] real :: p5(5) ! Pressures at five quadrature points, never rescaled from Pa [Pa] real :: r5(5) ! Densities at five quadrature points [R ~> kg m-3] or [kg m-3] real :: rho_anom ! The depth averaged density anomaly [R ~> kg m-3] or [kg m-3]. @@ -2198,44 +2213,48 @@ end subroutine evaluate_shape_quadratic !! 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, & - bathyP, dP_neglect, useMassWghtInterp) + bathyP, dP_neglect, useMassWghtInterp, SV_scale, pres_scale) 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 !< Potential temperature of the layer [degC]. real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & intent(in) :: S !< Salinity of the layer [ppt]. real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & - intent(in) :: p_t !< Pressure atop the layer [Pa]. + intent(in) :: p_t !< Pressure atop the layer [R L2 T-2 ~> Pa] or [Pa]. real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & - intent(in) :: p_b !< Pressure below the layer [Pa]. - real, intent(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 alpha_ref - !! alters the effects of roundoff, and answers do change. + intent(in) :: p_b !< Pressure below the layer [R L2 T-2 ~> Pa] or [Pa]. + real, intent(in) :: alpha_ref !< A mean specific volume that is subtracted out + !! to reduce the magnitude of each of the integrals [R-1 ~> 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(inout) :: dza !< The change in the geopotential anomaly - !! across the layer [m2 s-2]. + !! across the layer [L2 T-2 ~> m2 s-2] or [m2 s-2]. real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & - optional, intent(inout) :: intp_dza !< The integral in pressure through the - !! layer of the geopotential anomaly relative to the anomaly - !! at the bottom of the layer [Pa m2 s-2]. + optional, intent(inout) :: intp_dza !< The integral in pressure through the layer of + !! the geopotential anomaly relative to the anomaly at the bottom of the + !! layer [R L4 T-4 ~> Pa m2 s-2] or [Pa m2 s-2]. real, dimension(HI%IsdB:HI%IedB,HI%jsd:HI%jed), & - optional, intent(inout) :: 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 [m2 s-2]. + optional, intent(inout) :: 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 [L2 T-2 ~> m2 s-2] or [m2 s-2]. real, dimension(HI%isd:HI%ied,HI%JsdB:HI%JedB), & - optional, intent(inout) :: 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 [m2 s-2]. + optional, intent(inout) :: 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 [L2 T-2 ~> m2 s-2] or [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 [Pa] + optional, intent(in) :: bathyP !< The pressure at the bathymetry [R L2 T-2 ~> Pa] or [Pa] real, optional, intent(in) :: dP_neglect !< A miniscule pressure change with - !! the same units as p_t (Pa?) + !! the same units as p_t [R L2 T-2 ~> Pa] or [Pa] logical, optional, intent(in) :: useMassWghtInterp !< If true, uses mass weighting !! to interpolate T/S for top and bottom integrals. + real, optional, intent(in) :: SV_scale !< A multiplicative factor by which to scale specific + !! volume from m3 kg-1 to the desired units [kg m-3 R-1 ~> 1] + real, optional, intent(in) :: pres_scale !< A multiplicative factor to convert pressure + !! into Pa [Pa T2 R-1 L-2 ~> 1]. ! This subroutine calculates analytical and nearly-analytical integrals in ! pressure across layers of geopotential anomalies, which are required for @@ -2244,19 +2263,24 @@ subroutine int_spec_vol_dp_generic(T, S, p_t, p_b, alpha_ref, HI, EOS, & ! 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 :: T5(5), S5(5), p5(5), a5(5) - real :: alpha_anom ! The depth averaged specific density anomaly [m3 kg-1]. - real :: dp ! The pressure change through a layer [Pa]. -! real :: dp_90(2:4) ! The pressure change through a layer divided by 90 [Pa]. - real :: hWght ! A pressure-thickness below topography [Pa]. - real :: hL, hR ! Pressure-thicknesses of the columns to the left and right [Pa]. - real :: iDenom ! The inverse of the denominator in the weights [Pa-2]. + ! Local variables + real :: T5(5) ! Temperatures at five quadrature points [degC] + real :: S5(5) ! Salinities at five quadrature points [ppt] + real :: p5(5) ! Pressures at five quadrature points, scaled back to Pa if necessary [Pa] + real :: a5(5) ! Specific volumes at five quadrature points [R-1 ~> m3 kg-1] or [m3 kg-1] + real :: alpha_anom ! The depth averaged specific density anomaly [R-1 ~> m3 kg-1]. + real :: dp ! The pressure change through a layer [R L2 T-2 ~> Pa]. + real :: hWght ! A pressure-thickness below topography [R L2 T-2 ~> Pa]. + real :: hL, hR ! Pressure-thicknesses of the columns to the left and right [R L2 T-2 ~> Pa]. + real :: alpha_ref_mks ! The reference specific volume in MKS units, never rescaled from m3 kg-1 [m3 kg-1] + real :: iDenom ! The inverse of the denominator in the weights [T4 R-2 L-4 ~> 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 weights 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 [m2 s-2]. + ! 5 sub-column locations [L2 T-2 ~> m2 s-2]. + real :: RL2_T2_to_Pa ! A unit conversion factor from the rescaled units of pressure to Pa [Pa T2 R-1 L-2 ~> 1] 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 @@ -2267,6 +2291,9 @@ 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 + RL2_T2_to_Pa = 1.0 ; if (present(pres_scale)) RL2_T2_to_Pa = pres_scale + alpha_ref_mks = alpha_ref ; if (present(SV_scale)) alpha_ref_mks = alpha_ref / SV_scale + do_massWeight = .false. if (present(useMassWghtInterp)) then ; if (useMassWghtInterp) then do_massWeight = .true. @@ -2280,9 +2307,9 @@ subroutine int_spec_vol_dp_generic(T, S, p_t, p_b, alpha_ref, HI, EOS, & 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 + p5(n) = RL2_T2_to_Pa * (p_b(i,j) - 0.25*real(n-1)*dp) enddo - call calculate_spec_vol(T5, S5, p5, a5, 1, 5, EOS, alpha_ref) + call calculate_spec_vol(T5, S5, p5, a5, 1, 5, EOS, alpha_ref_mks, scale=SV_scale) ! 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)) @@ -2318,15 +2345,15 @@ subroutine int_spec_vol_dp_generic(T, S, p_t, p_b, alpha_ref, HI, EOS, & ! 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) + p5(1) = RL2_T2_to_Pa * (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 + T5(n) = T5(1) ; S5(n) = S5(1) ; p5(n) = p5(n-1) - RL2_T2_to_Pa * 0.25*dp enddo - call calculate_spec_vol(T5, S5, p5, a5, 1, 5, EOS, alpha_ref) + call calculate_spec_vol(T5, S5, p5, a5, 1, 5, EOS, alpha_ref_mks, scale=SV_scale) ! 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)) + & @@ -2362,14 +2389,14 @@ subroutine int_spec_vol_dp_generic(T, S, p_t, p_b, alpha_ref, HI, EOS, & ! 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) + p5(1) = RL2_T2_to_Pa * (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 + T5(n) = T5(1) ; S5(n) = S5(1) ; p5(n) = RL2_T2_to_Pa * (p5(n-1) - 0.25*dp) enddo - call calculate_spec_vol(T5, S5, p5, a5, 1, 5, EOS, alpha_ref) + call calculate_spec_vol(T5, S5, p5, a5, 1, 5, EOS, alpha_ref_mks, scale=SV_scale) ! 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)) + & @@ -2388,7 +2415,7 @@ end subroutine int_spec_vol_dp_generic !! 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) + intp_dza, intx_dza, inty_dza, useMassWghtInterp, SV_scale, pres_scale) 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 [degC]. @@ -2399,36 +2426,40 @@ subroutine int_spec_vol_dp_generic_plm(T_t, T_b, S_t, S_b, p_t, p_b, alpha_ref, real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & intent(in) :: S_b !< Salinity at the bottom the layer [ppt]. real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & - intent(in) :: p_t !< Pressure atop the layer [Pa]. + intent(in) :: p_t !< Pressure atop the layer [R L2 T-2 ~> Pa] or [Pa]. real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & - intent(in) :: p_b !< Pressure below the layer [Pa]. - real, intent(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 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?) + intent(in) :: p_b !< Pressure below the layer [R L2 T-2 ~> Pa] or [Pa]. + real, intent(in) :: alpha_ref !< A mean specific volume that is subtracted out + !! to reduce the magnitude of each of the integrals [R-1 ~> 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 ! Pa] or [Pa] real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & - intent(in) :: bathyP !< The pressure at the bathymetry [Pa] + intent(in) :: bathyP !< The pressure at the bathymetry [R L2 T-2 ~> Pa] or [Pa] type(EOS_type), pointer :: EOS !< Equation of state structure real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & intent(inout) :: dza !< The change in the geopotential anomaly - !! across the layer [m2 s-2]. + !! across the layer [L2 T-2 ~> m2 s-2]. real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & - optional, intent(inout) :: intp_dza !< The integral in pressure through the - !! layer of the geopotential anomaly relative to the anomaly - !! at the bottom of the layer [Pa m2 s-2]. + optional, intent(inout) :: intp_dza !< The integral in pressure through the layer of + !! the geopotential anomaly relative to the anomaly at the bottom of the + !! layer [R L4 T-4 ~> Pa m2 s-2] or [Pa m2 s-2]. real, dimension(HI%IsdB:HI%IedB,HI%jsd:HI%jed), & - optional, intent(inout) :: 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 [m2 s-2]. + optional, intent(inout) :: 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 [L2 T-2 ~> m2 s-2] or [m2 s-2]. real, dimension(HI%isd:HI%ied,HI%JsdB:HI%JedB), & - optional, intent(inout) :: 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 [m2 s-2]. + optional, intent(inout) :: 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 [L2 T-2 ~> m2 s-2] or [m2 s-2]. logical, optional, intent(in) :: useMassWghtInterp !< If true, uses mass weighting !! to interpolate T/S for top and bottom integrals. + real, optional, intent(in) :: SV_scale !< A multiplicative factor by which to scale specific + !! volume from m3 kg-1 to the desired units [kg m-3 R-1 ~> 1] + real, optional, intent(in) :: pres_scale !< A multiplicative factor to convert pressure + !! into Pa [Pa T2 R-1 L-2 ~> 1]. ! This subroutine calculates analytical and nearly-analytical integrals in ! pressure across layers of geopotential anomalies, which are required for @@ -2437,23 +2468,31 @@ subroutine int_spec_vol_dp_generic_plm(T_t, T_b, S_t, S_b, p_t, p_b, alpha_ref, ! 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 :: T5(5) ! Temperatures at five quadrature points [degC] + real :: S5(5) ! Salinities at five quadrature points [ppt] + real :: p5(5) ! Pressures at five quadrature points, scaled back to Pa as necessary [Pa] + real :: a5(5) ! Specific volumes at five quadrature points [R-1 ~> m3 kg-1] or [m3 kg-1] + real :: T15(15) ! Temperatures at fifteen interior quadrature points [degC] + real :: S15(15) ! Salinities at fifteen interior quadrature points [ppt] + real :: p15(15) ! Pressures at fifteen quadrature points, scaled back to Pa as necessary [Pa] + real :: a15(15) ! Specific volumes at fifteen quadrature points [R-1 ~> m3 kg-1] or [m3 kg-1] + real :: wt_t(5), wt_b(5) ! Weights of top and bottom values at quadrature points [nondim] real :: T_top, T_bot, S_top, S_bot, P_top, P_bot real :: alpha_anom ! The depth averaged specific density anomaly [m3 kg-1]. - real :: dp ! The pressure change through a layer [Pa]. - real :: dp_90(2:4) ! The pressure change through a layer divided by 90 [Pa]. - real :: hWght ! A pressure-thickness below topography [Pa]. - real :: hL, hR ! Pressure-thicknesses of the columns to the left and right [Pa]. - real :: iDenom ! The inverse of the denominator in the weights [Pa-2]. + real :: dp ! The pressure change through a layer [R L2 T-2 ~> Pa]. + real :: dp_90(2:4) ! The pressure change through a layer divided by 90 [R L2 T-2 ~> Pa]. + real :: hWght ! A pressure-thickness below topography [R L2 T-2 ~> Pa]. + real :: hL, hR ! Pressure-thicknesses of the columns to the left and right [R L2 T-2 ~> Pa]. + real :: alpha_ref_mks ! The reference specific volume in MKS units, never rescaled from m3 kg-1 [m3 kg-1] + real :: iDenom ! The inverse of the denominator in the weights [T4 R-2 L-4 ~> 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 weights 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 [m2 s-2]. + ! 5 sub-column locations [L2 T-2 ~> m2 s-2]. + real :: RL2_T2_to_Pa ! A unit conversion factor from the rescaled units of pressure to Pa [Pa T2 R-1 L-2 ~> 1] 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 @@ -2463,6 +2502,10 @@ subroutine int_spec_vol_dp_generic_plm(T_t, T_b, S_t, S_b, p_t, p_b, alpha_ref, do_massWeight = .false. if (present(useMassWghtInterp)) do_massWeight = useMassWghtInterp + RL2_T2_to_Pa = 1.0 ; if (present(pres_scale)) RL2_T2_to_Pa = pres_scale + alpha_ref_mks = alpha_ref ; if (present(SV_scale)) alpha_ref_mks = alpha_ref / SV_scale + + 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) @@ -2474,11 +2517,11 @@ subroutine int_spec_vol_dp_generic_plm(T_t, T_b, S_t, S_b, p_t, p_b, alpha_ref, 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) + p5(n) = RL2_T2_to_Pa * (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) + call calculate_spec_vol(T5, S5, p5, a5, 1, 5, EOS, alpha_ref_mks, scale=SV_scale) ! 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)) @@ -2529,13 +2572,13 @@ subroutine int_spec_vol_dp_generic_plm(T_t, T_b, S_t, S_b, p_t, p_b, alpha_ref, ! 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 + p15(pos+n) = RL2_T2_to_Pa * (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) + call calculate_spec_vol(T15, S15, p15, a15, 1, 15, EOS, alpha_ref_mks, scale=SV_scale) intp(1) = dza(i,j) ; intp(5) = dza(i+1,j) do m=2,4 @@ -2588,13 +2631,13 @@ subroutine int_spec_vol_dp_generic_plm(T_t, T_b, S_t, S_b, p_t, p_b, alpha_ref, ! 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 + p15(pos+n) = RL2_T2_to_Pa * (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) + call calculate_spec_vol(T15, S15, p15, a15, 1, 15, EOS, alpha_ref_mks, scale=SV_scale) intp(1) = dza(i,j) ; intp(5) = dza(i,j+1) do m=2,4 diff --git a/src/equation_of_state/MOM_EOS_Wright.F90 b/src/equation_of_state/MOM_EOS_Wright.F90 index 39d1dd26d4..cd590aa611 100644 --- a/src/equation_of_state/MOM_EOS_Wright.F90 +++ b/src/equation_of_state/MOM_EOS_Wright.F90 @@ -631,7 +631,7 @@ end subroutine int_density_dz_wright !! 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, spv_ref, HI, dza, & intp_dza, intx_dza, inty_dza, halo_size, & - bathyP, dP_neglect, useMassWghtInterp) + bathyP, dP_neglect, useMassWghtInterp, SV_scale, pres_scale) 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 @@ -639,53 +639,66 @@ subroutine int_spec_vol_dp_wright(T, S, p_t, p_b, spv_ref, HI, dza, & real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & intent(in) :: S !< Salinity [PSU]. real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & - intent(in) :: p_t !< Pressure at the top of the layer [Pa]. + intent(in) :: p_t !< Pressure at the top of the layer [R L2 T-2 ~> Pa] or [Pa]. real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & - intent(in) :: p_b !< Pressure at the top of the layer [Pa]. + intent(in) :: p_b !< Pressure at the top of the layer [R L2 T-2 ~> Pa] or [Pa]. 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 spv_ref, but this reduces the - !! effects of roundoff. + !! to reduce the magnitude of each of the integrals [R-1 ~> m3 kg-1]. + !! The calculation is 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(inout) :: dza !< The change in the geopotential anomaly across - !! the layer [m2 s-2]. + !! the layer [T-2 ~> m2 s-2] or [m2 s-2]. real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & optional, intent(inout) :: intp_dza !< The integral in pressure through the layer of !! the geopotential anomaly relative to the anomaly - !! at the bottom of the layer [Pa m2 s-2]. + !! at the bottom of the layer [R L4 T-4 ~> Pa m2 s-2] + !! or [Pa m2 s-2]. real, dimension(HI%IsdB:HI%IedB,HI%jsd:HI%jed), & optional, intent(inout) :: 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 [m2 s-2]. + !! the layer divided by the x grid spacing + !! [L2 T-2 ~> m2 s-2] or [m2 s-2]. real, dimension(HI%isd:HI%ied,HI%JsdB:HI%JedB), & optional, intent(inout) :: 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 [m2 s-2]. + !! the layer divided by the y grid spacing + !! [L2 T-2 ~> m2 s-2] or [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 [Pa] + optional, intent(in) :: bathyP !< The pressure at the bathymetry [R L2 T-2 ~> Pa] or [Pa] real, optional, intent(in) :: dP_neglect !< A miniscule pressure change with - !! the same units as p_t [Pa] + !! the same units as p_t [R L2 T-2 ~> Pa] or [Pa] logical, optional, intent(in) :: useMassWghtInterp !< If true, uses mass weighting !! to interpolate T/S for top and bottom integrals. + real, optional, intent(in) :: SV_scale !< A multiplicative factor by which to scale specific + !! volume from m3 kg-1 to the desired units [kg m-3 R-1 ~> 1] + real, optional, intent(in) :: pres_scale !< A multiplicative factor to convert pressure + !! into Pa [Pa T2 R-1 L-2 ~> 1]. ! Local variables real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed) :: al0_2d, p0_2d, lambda_2d - real :: al0, p0, lambda - real :: p_ave - real :: rem, eps, eps2 - real :: alpha_anom ! The depth averaged specific volume anomaly [m3 kg-1]. - real :: dp ! The pressure change through a layer [Pa]. - real :: hWght ! A pressure-thickness below topography [Pa]. - real :: hL, hR ! Pressure-thicknesses of the columns to the left and right [Pa]. - real :: iDenom ! The inverse of the denominator in the weights [Pa-2]. + real :: al0 ! A term in the Wright EOS [R-1 ~> m3 kg-1] + real :: p0 ! A term in the Wright EOS [R L2 T-2 ~> Pa] + real :: lambda ! A term in the Wright EOS [L2 T-2 ~> m2 s-2] + real :: al0_scale ! Scaling factor to convert al0 from MKS units [R-1 kg m-3 ~> 1] + real :: p0_scale ! Scaling factor to convert p0 from MKS units [R L2 T-2 Pa-1 ~> 1] + real :: lam_scale ! Scaling factor to convert lambda from MKS units [L2 s2 T-2 m-2 ~> 1] + real :: p_ave ! The layer average pressure [R L2 T-2 ~> Pa] + real :: rem ! [L2 T-2 ~> m2 s-2] + real :: eps, eps2 ! A nondimensional ratio and its square [nondim] + real :: alpha_anom ! The depth averaged specific volume anomaly [R-1 ~> m3 kg-1]. + real :: dp ! The pressure change through a layer [R L2 T-2 ~> Pa]. + real :: hWght ! A pressure-thickness below topography [R L2 T-2 ~> Pa]. + real :: hL, hR ! Pressure-thicknesses of the columns to the left and right [R L2 T-2 ~> Pa]. + real :: iDenom ! The inverse of the denominator in the weights [T4 R-2 L-4 ~> 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 weights 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 [m2 s-2]. + ! 5 sub-column locations [L2 T-2 ~> 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. @@ -697,6 +710,14 @@ subroutine int_spec_vol_dp_wright(T, S, p_t, p_b, spv_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 + + al0_scale = 1.0 ; if (present(SV_scale)) al0_scale = SV_scale + p0_scale = 1.0 + if (present(pres_scale)) then ; if (pres_scale /= 1.0) then + p0_scale = 1.0 / pres_scale + endif ; endif + lam_scale = al0_scale * p0_scale + do_massWeight = .false. if (present(useMassWghtInterp)) then ; if (useMassWghtInterp) then do_massWeight = .true. @@ -706,10 +727,11 @@ subroutine int_spec_vol_dp_wright(T, S, p_t, p_b, spv_ref, HI, dza, & ! "dP_neglect must be present if useMassWghtInterp is present and true.") endif ; endif + ! alpha(j) = (lambda + al0*(pressure(j) + p0)) / (pressure(j) + p0) 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_2d(i,j) = al0_scale * ( (a0 + a1*T(i,j)) + a2*S(i,j) ) + p0_2d(i,j) = p0_scale * ( (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) = lam_scale * ( (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) diff --git a/src/equation_of_state/MOM_EOS_linear.F90 b/src/equation_of_state/MOM_EOS_linear.F90 index 2c19b617c6..623db27ad3 100644 --- a/src/equation_of_state/MOM_EOS_linear.F90 +++ b/src/equation_of_state/MOM_EOS_linear.F90 @@ -510,56 +510,56 @@ subroutine int_spec_vol_dp_linear(T, S, p_t, p_b, alpha_ref, HI, Rho_T0_S0, & real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & intent(in) :: S !< Salinity [PSU]. real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & - intent(in) :: p_t !< Pressure at the top of the layer [Pa]. + intent(in) :: p_t !< Pressure at the top of the layer [R L2 T-2 ~> Pa] or [Pa]. real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & - intent(in) :: p_b !< Pressure at the top of the layer [Pa]. - real, intent(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. - real, intent(in) :: Rho_T0_S0 !< The density at T=0, S=0 [kg m-3]. + intent(in) :: p_b !< Pressure at the top of the layer [R L2 T-2 ~> Pa] or [Pa]. + real, intent(in) :: alpha_ref !< A mean specific volume that is subtracted out + !! to reduce the magnitude of each of the integrals [R-1 ~> m3 kg-1]. + !! The calculation is mathematically identical with different values of + !! alpha_ref, but this reduces the effects of roundoff. + real, intent(in) :: Rho_T0_S0 !< The density at T=0, S=0 [R ~> kg m-3] or [kg m-3]. real, intent(in) :: dRho_dT !< The derivative of density with temperature - !! [kg m-3 degC-1]. + !! [R degC-1 ~> kg m-3 degC-1] or [kg m-3 degC-1]. real, intent(in) :: dRho_dS !< The derivative of density with salinity, - !! in [kg m-3 ppt-1]. + !! in [R ppt-1 ~> kg m-3 ppt-1] or [kg m-3 ppt-1]. real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & intent(out) :: dza !< The change in the geopotential anomaly across - !! the layer [m2 s-2]. + !! the layer [L2 T-2 ~> m2 s-2] or [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 [Pa m2 s-2]. + 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 [R L4 T-4 ~> Pa m2 s-2] or [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 - !! [m2 s-2]. + !! [L2 T-2 ~> m2 s-2] or [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 - !! [m2 s-2]. + !! [L2 T-2 ~> m2 s-2] or [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 [Pa] + optional, intent(in) :: bathyP !< The pressure at the bathymetry [R L2 T-2 ~> Pa] or [Pa] real, optional, intent(in) :: dP_neglect !< A miniscule pressure change with - !! the same units as p_t [Pa] + !! the same units as p_t [R L2 T-2 ~> Pa] or [Pa] logical, optional, intent(in) :: useMassWghtInterp !< If true, uses mass weighting !! to interpolate T/S for top and bottom integrals. ! Local variables - real :: dRho_TS ! The density anomaly due to T and S [kg m-3]. - real :: alpha_anom ! The specific volume anomaly from 1/rho_ref [m3 kg-1]. - real :: aaL, aaR ! rho_anom to the left and right [kg m-3]. - real :: dp, dpL, dpR ! Layer pressure thicknesses [Pa]. - real :: hWght ! A pressure-thickness below topography [Pa]. - real :: hL, hR ! Pressure-thicknesses of the columns to the left and right [Pa]. - real :: iDenom ! The inverse of the denominator in the weights [Pa-2]. + real :: dRho_TS ! The density anomaly due to T and S [R ~> kg m-3] or [kg m-3]. + real :: alpha_anom ! The specific volume anomaly from 1/rho_ref [R-1 ~> m3 kg-1] or [m3 kg-1]. + real :: aaL, aaR ! The specific volume anomaly to the left and right [R-1 ~> m3 kg-1] or [m3 kg-1]. + real :: dp, dpL, dpR ! Layer pressure thicknesses [R L2 T-2 ~> Pa] or [Pa]. + real :: hWght ! A pressure-thickness below topography [R L2 T-2 ~> Pa] or [Pa]. + real :: hL, hR ! Pressure-thicknesses of the columns to the left and right [R L2 T-2 ~> Pa] or [Pa]. + real :: iDenom ! The inverse of the denominator in the weights [T4 R-2 L-2 ~> Pa-2] or [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 weights 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 [m2 s-2]. + ! 5 sub-column locations [L2 T-2 ~> m2 s-2] or [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 From 3b3c34ab94506283479290fbb2472211cba08e00 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sun, 5 Apr 2020 09:06:49 -0400 Subject: [PATCH 148/316] +Rescaled non-Boussinesq pressure force calcs Rescaled the pressures and specific volumes in the non-Boussinesq pressure force calculations, including changing the units of the pressures passed to set_pbce_nonBouss and using the new SV_scale and pres_scale arguments to the equation of state routines. All answers are bitwise identical. --- src/core/MOM_PressureForce_Montgomery.F90 | 105 ++++++++++----------- src/core/MOM_PressureForce_analytic_FV.F90 | 104 ++++++++++---------- src/core/MOM_PressureForce_blocked_AFV.F90 | 102 ++++++++++---------- 3 files changed, 148 insertions(+), 163 deletions(-) diff --git a/src/core/MOM_PressureForce_Montgomery.F90 b/src/core/MOM_PressureForce_Montgomery.F90 index e0177e35b9..2aa13c5f39 100644 --- a/src/core/MOM_PressureForce_Montgomery.F90 +++ b/src/core/MOM_PressureForce_Montgomery.F90 @@ -82,8 +82,8 @@ subroutine PressureForce_Mont_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, pb real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: & M, & ! The Montgomery potential, M = (p/rho + gz) [L2 T-2 ~> m2 s-2]. alpha_star, & ! Compression adjusted specific volume [R-1 ~> m3 kg-1]. - dz_geo ! The change in geopotential across a layer [m2 s-2]. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1) :: p ! Interface pressure [Pa]. + dz_geo ! The change in geopotential across a layer [L2 T-2 ~> m2 s-2]. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1) :: p ! Interface pressure [R L2 T-2 ~> Pa]. ! p may be adjusted (with a nonlinear equation of state) so that ! its derivative compensates for the adiabatic compressibility ! in seawater, but p will still be close to the pressure. @@ -97,10 +97,9 @@ subroutine PressureForce_Mont_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, pb ! deepest variable density near-surface layer [R ~> kg m-3]. real, dimension(SZI_(G),SZJ_(G)) :: & - dM, & ! A barotropic correction to the Montgomery potentials to - ! enable the use of a reduced gravity form of the equations - ! [m2 s-2]. - dp_star, & ! Layer thickness after compensation for compressibility [Pa]. + dM, & ! A barotropic correction to the Montgomery potentials to enable the use + ! of a reduced gravity form of the equations [L2 T-2 ~> m2 s-2]. + dp_star, & ! Layer thickness after compensation for compressibility [R L2 T-2 ~> Pa]. SSH, & ! The sea surface height anomaly, in depth units [Z ~> m]. e_tidal, & ! Bottom geopotential anomaly due to tidal forces from ! astronomical sources and self-attraction and loading [Z ~> m]. @@ -112,20 +111,16 @@ subroutine PressureForce_Mont_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, pb real :: PFu_bc, PFv_bc ! The pressure gradient force due to along-layer ! compensated density gradients [L T-2 ~> m s-2] real :: dp_neglect ! A thickness that is so small it is usually lost - ! in roundoff and can be neglected [Pa]. + ! in roundoff and can be neglected [R L2 T-2 ~> Pa]. 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. - logical :: is_split ! A flag indicating whether the pressure - ! gradient terms are to be split into - ! barotropic and baroclinic pieces. + logical :: use_EOS ! If true, density is calculated from T & S using an equation of state. + logical :: is_split ! A flag indicating whether the pressure gradient terms are to be + ! split into barotropic and baroclinic pieces. type(thermo_var_ptrs) :: tv_tmp! A structure of temporary T & S. - real :: I_gEarth ! The inverse of g_Earth [s2 Z m-2 ~> s2 m-1] + real :: I_gEarth ! The inverse of g_Earth [T2 Z L-2 ~> s2 m-1] ! real :: dalpha - real :: Pa_to_p_dyn ! A conversion factor from Pa (= kg m-1 s-2) to the units of - ! dynamic pressure (R L2 T-2) [ R L2 T-2 m s2 kg-1 ~> nondim] - real :: Pa_to_H ! A factor to convert from Pa to the thicknesss units (H). + real :: Pa_to_H ! A factor to convert from R L2 T-2 to the thickness units (H). real :: alpha_Lay(SZK_(G)) ! The specific volume of each layer [R-1 ~> m3 kg-1]. real :: dalpha_int(SZK_(G)+1) ! The change in specific volume across each ! interface [R-1 ~> m3 kg-1]. @@ -148,35 +143,34 @@ subroutine PressureForce_Mont_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, pb "can no longer be used with a compressible EOS. Use #define ANALYTIC_FV_PGF.") endif - Pa_to_p_dyn = US%kg_m3_to_R * US%m_s_to_L_T**2 - I_gEarth = 1.0 / (US%L_T_to_m_s**2 * GV%g_Earth) - dp_neglect = GV%H_to_Pa * GV%H_subroundoff + I_gEarth = 1.0 / GV%g_Earth + dp_neglect = GV%g_Earth * GV%H_to_RZ * GV%H_subroundoff do k=1,nz ; alpha_Lay(k) = 1.0 / (GV%Rlay(k)) ; enddo do k=2,nz ; dalpha_int(K) = alpha_Lay(k-1) - alpha_Lay(k) ; enddo 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 + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 ; p(i,j,1) = US%kg_m3_to_R*US%m_s_to_L_T**2*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 ; enddo ; enddo endif !$OMP parallel do default(shared) do j=Jsq,Jeq+1 ; do k=1,nz ; do i=Isq,Ieq+1 - p(i,j,K+1) = p(i,j,K) + GV%H_to_Pa * h(i,j,k) + p(i,j,K+1) = p(i,j,K) + GV%g_Earth * GV%H_to_RZ * h(i,j,k) enddo ; enddo ; enddo if (present(eta)) then - Pa_to_H = 1.0 / GV%H_to_Pa + Pa_to_H = 1.0 / (GV%g_Earth * GV%H_to_RZ) 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. + eta(i,j) = (p(i,j,nz+1) - US%kg_m3_to_R*US%m_s_to_L_T**2*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. + eta(i,j) = p(i,j,nz+1) * Pa_to_H ! eta has the same units as h. enddo ; enddo endif endif @@ -192,10 +186,11 @@ subroutine PressureForce_Mont_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, pb !$OMP parallel do default(shared) do k=1,nz call int_specific_vol_dp(tv%T(:,:,k), tv%S(:,:,k), p(:,:,k), p(:,:,k+1), & - 0.0, G%HI, tv%eqn_of_state, dz_geo(:,:,k), halo_size=1) + 0.0, G%HI, tv%eqn_of_state, dz_geo(:,:,k), halo_size=1, & + SV_scale=US%R_to_kg_m3, pres_scale=US%R_to_kg_m3*US%L_T_to_m_s**2) enddo !$OMP parallel do default(shared) - do j=Jsq,Jeq+1 ; do k=1,nz; do i=Isq,Ieq+1 + do j=Jsq,Jeq+1 ; do k=1,nz ; do i=Isq,Ieq+1 SSH(i,j) = SSH(i,j) + I_gEarth * dz_geo(i,j,k) enddo ; enddo ; enddo else @@ -260,20 +255,20 @@ subroutine PressureForce_Mont_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, pb !$OMP parallel do default(shared) do j=Jsq,Jeq+1 do i=Isq,Ieq+1 - M(i,j,nz) = geopot_bot(i,j) + Pa_to_p_dyn*p(i,j,nz+1) * alpha_star(i,j,nz) + M(i,j,nz) = geopot_bot(i,j) + p(i,j,nz+1) * alpha_star(i,j,nz) enddo do k=nz-1,1,-1 ; do i=Isq,Ieq+1 - M(i,j,k) = M(i,j,k+1) + Pa_to_p_dyn*p(i,j,K+1) * (alpha_star(i,j,k) - alpha_star(i,j,k+1)) + M(i,j,k) = M(i,j,k+1) + p(i,j,K+1) * (alpha_star(i,j,k) - alpha_star(i,j,k+1)) enddo ; enddo enddo else ! not use_EOS !$OMP parallel do default(shared) do j=Jsq,Jeq+1 do i=Isq,Ieq+1 - M(i,j,nz) = geopot_bot(i,j) + Pa_to_p_dyn*p(i,j,nz+1) * alpha_Lay(nz) + M(i,j,nz) = geopot_bot(i,j) + p(i,j,nz+1) * alpha_Lay(nz) enddo do k=nz-1,1,-1 ; do i=Isq,Ieq+1 - M(i,j,k) = M(i,j,k+1) + Pa_to_p_dyn*p(i,j,K+1) * dalpha_int(K+1) + M(i,j,k) = M(i,j,k+1) + p(i,j,K+1) * dalpha_int(K+1) enddo ; enddo enddo endif ! use_EOS @@ -296,11 +291,11 @@ subroutine PressureForce_Mont_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, pb ! enddo ; enddo ! if (use_EOS) then ! do k=2,nz ; do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 -! M(i,j,k) = M(i,j,k-1) - Pa_to_p_dyn*p(i,j,K) * (alpha_star(i,j,k-1) - alpha_star(i,j,k)) +! M(i,j,k) = M(i,j,k-1) - p(i,j,K) * (alpha_star(i,j,k-1) - alpha_star(i,j,k)) ! enddo ; enddo ; enddo ! else ! not use_EOS ! do k=2,nz ; do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 -! M(i,j,k) = M(i,j,k-1) - Pa_to_p_dyn*p(i,j,K) * dalpha_int(K) +! M(i,j,k) = M(i,j,k-1) - p(i,j,K) * dalpha_int(K) ! enddo ; enddo ; enddo ! endif ! use_EOS @@ -321,16 +316,16 @@ subroutine PressureForce_Mont_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, pb enddo ; enddo do j=js,je ; do I=Isq,Ieq ! PFu_bc = p* grad alpha* - PFu_bc = (alpha_star(i+1,j,k) - alpha_star(i,j,k)) * (G%IdxCu(I,j) * Pa_to_p_dyn * & - ((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_bc = (alpha_star(i+1,j,k) - alpha_star(i,j,k)) * (G%IdxCu(I,j) * & + ((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 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) * Pa_to_p_dyn * & - ((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_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 enddo ; enddo @@ -707,22 +702,22 @@ end subroutine Set_pbce_Bouss subroutine Set_pbce_nonBouss(p, tv, G, GV, US, GFS_scale, pbce, alpha_star) 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) :: p !< Interface pressures [Pa]. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1), intent(in) :: p !< Interface pressures [R L2 T-2 ~> Pa]. type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamic variables - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real, intent(in) :: GFS_scale !< Ratio between gravity applied to top !! interface and the gravitational acceleration of !! the planet [nondim]. 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 - !! [L2 H-1 T-2 ~> m4 kg-1 s-2]. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(out) :: pbce !< The baroclinic pressure anomaly in each + !! layer due to free surface height anomalies + !! [L2 H-1 T-2 ~> m4 kg-1 s-2]. real, dimension(SZI_(G),SZJ_(G),SZK_(G)), optional, intent(in) :: alpha_star !< The layer specific volumes !! (maybe compressibility compensated) [R-1 ~> m3 kg-1]. ! Local variables real, dimension(SZI_(G),SZJ_(G)) :: & dpbce, & ! A barotropic correction to the pbce to enable the use of ! a reduced gravity form of the equations [L2 H-1 T-2 ~> m4 kg-1 s-2]. - C_htot ! dP_dH divided by the total ocean pressure [R L2 T-2 H-1 Pa-1 ~> m2 kg-1]. + C_htot ! dP_dH divided by the total ocean pressure [H-1 ~> m2 kg-1]. real :: T_int(SZI_(G)) ! Interface temperature [degC]. real :: S_int(SZI_(G)) ! Interface salinity [ppt]. real :: dR_dT(SZI_(G)) ! Partial derivative of density with temperature [R degC-1 ~> kg m-3 degC-1]. @@ -733,9 +728,8 @@ subroutine Set_pbce_nonBouss(p, tv, G, GV, US, GFS_scale, pbce, alpha_star) real :: dP_dH ! A factor that converts from thickness to pressure times other dimensional ! conversion factors [R L2 T-2 H-1 ~> Pa m2 kg-1]. real :: dp_neglect ! A thickness that is so small it is usually lost - ! in roundoff and can be neglected [Pa]. - logical :: use_EOS ! If true, density is calculated from T & S using - ! an equation of state. + ! in roundoff and can be neglected [R L2 T-2 ~> Pa]. + logical :: use_EOS ! If true, density is calculated from T & S using an equation of state. integer :: Isq, Ieq, Jsq, Jeq, nz, i, j, k Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB ; nz = G%ke @@ -743,7 +737,7 @@ subroutine Set_pbce_nonBouss(p, tv, G, GV, US, GFS_scale, pbce, alpha_star) use_EOS = associated(tv%eqn_of_state) dP_dH = GV%g_Earth * GV%H_to_RZ - dp_neglect = GV%H_to_Pa * GV%H_subroundoff + dp_neglect = GV%g_Earth * GV%H_to_RZ * GV%H_subroundoff if (use_EOS) then if (present(alpha_star)) then @@ -761,8 +755,9 @@ subroutine Set_pbce_nonBouss(p, tv, G, GV, US, GFS_scale, pbce, alpha_star) else !$OMP parallel do default(shared) private(T_int,S_int,dR_dT,dR_dS,rho_in_situ) do j=Jsq,Jeq+1 - call calculate_density(tv%T(:,j,nz), tv%S(:,j,nz), p(:,j,nz+1), & - rho_in_situ, Isq, Ieq-Isq+2, tv%eqn_of_state, scale=US%kg_m3_to_R) + call calculate_density(tv%T(:,j,nz), tv%S(:,j,nz), p(:,j,nz+1), rho_in_situ, & + Isq, Ieq-Isq+2, tv%eqn_of_state, scale=US%kg_m3_to_R, & + pres_scale=US%R_to_kg_m3*US%L_T_to_m_s**2) do i=Isq,Ieq+1 C_htot(i,j) = dP_dH / ((p(i,j,nz+1)-p(i,j,1)) + dp_neglect) pbce(i,j,nz) = dP_dH / (rho_in_situ(i)) @@ -772,10 +767,11 @@ subroutine Set_pbce_nonBouss(p, tv, G, GV, US, GFS_scale, pbce, alpha_star) T_int(i) = 0.5*(tv%T(i,j,k)+tv%T(i,j,k+1)) S_int(i) = 0.5*(tv%S(i,j,k)+tv%S(i,j,k+1)) enddo - call calculate_density(T_int, S_int, p(:,j,k+1), rho_in_situ, & - Isq, Ieq-Isq+2, tv%eqn_of_state, scale=US%kg_m3_to_R) + call calculate_density(T_int, S_int, p(:,j,k+1), rho_in_situ, Isq, Ieq-Isq+2, tv%eqn_of_state, & + scale=US%kg_m3_to_R, pres_scale=US%R_to_kg_m3*US%L_T_to_m_s**2) call calculate_density_derivs(T_int, S_int, p(:,j,k+1), dR_dT, dR_dS, & - Isq, Ieq-Isq+2, tv%eqn_of_state, scale=US%kg_m3_to_R) + Isq, Ieq-Isq+2, tv%eqn_of_state, & + scale=US%kg_m3_to_R, pres_scale=US%R_to_kg_m3*US%L_T_to_m_s**2) do i=Isq,Ieq+1 pbce(i,j,k) = pbce(i,j,k+1) + ((p(i,j,K+1)-p(i,j,1))*C_htot(i,j)) * & ((dR_dT(i)*(tv%T(i,j,k+1)-tv%T(i,j,k)) + & @@ -796,8 +792,7 @@ subroutine Set_pbce_nonBouss(p, tv, G, GV, US, GFS_scale, pbce, alpha_star) pbce(i,j,nz) = dP_dH * alpha_Lay(nz) enddo do k=nz-1,1,-1 ; do i=Isq,Ieq+1 - pbce(i,j,k) = pbce(i,j,k+1) + ((p(i,j,K+1)-p(i,j,1))*C_htot(i,j)) * & - dalpha_int(K+1) + pbce(i,j,k) = pbce(i,j,k+1) + ((p(i,j,K+1)-p(i,j,1))*C_htot(i,j)) * dalpha_int(K+1) enddo ; enddo enddo endif ! use_EOS diff --git a/src/core/MOM_PressureForce_analytic_FV.F90 b/src/core/MOM_PressureForce_analytic_FV.F90 index d0a6932810..aca19a6ec6 100644 --- a/src/core/MOM_PressureForce_analytic_FV.F90 +++ b/src/core/MOM_PressureForce_analytic_FV.F90 @@ -118,7 +118,7 @@ subroutine PressureForce_AFV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p !! calculate PFu and PFv [H ~> m or kg m-2], with any tidal !! contributions or compressibility compensation. ! Local variables - real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1) :: p ! Interface pressure [Pa]. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1) :: p ! Interface pressure [R L2 T-2 ~> 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 [degC]. @@ -131,11 +131,11 @@ subroutine PressureForce_AFV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p T_b ! of temperature within each layer [degC]. real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: & dza, & ! The change in geopotential anomaly between the top and bottom - ! of a layer [m2 s-2]. + ! of a layer [L2 T-2 ~> m2 s-2]. intp_dza ! The vertical integral in depth of the pressure anomaly less - ! the pressure anomaly at the top of the layer [Pa m2 s-2]. + ! the pressure anomaly at the top of the layer [R L4 Z-4 ~> Pa m2 s-2]. real, dimension(SZI_(G),SZJ_(G)) :: & - dp, & ! The (positive) change in pressure across a layer [Pa]. + dp, & ! The (positive) change in pressure across a layer [R L2 Z-2 ~> Pa]. SSH, & ! The sea surface height anomaly, in depth units [Z ~> m]. e_tidal, & ! The bottom geopotential anomaly due to tidal forces from ! astronomical sources and self-attraction and loading [Z ~> m]. @@ -148,33 +148,32 @@ subroutine PressureForce_AFV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p ! density near-surface layer [R ~> kg m-3]. 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]. + ! interface below a layer, divided by the grid spacing [L2 T-2 ~> m2 s-2]. real, dimension(SZIB_(G),SZJ_(G),SZK_(G)) :: & - intx_dza ! The change in intx_za through a layer [m2 s-2]. + intx_dza ! The change in intx_za through a layer [L2 T-2 ~> 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]. + ! interface below a layer, divided by the grid spacing [L2 T-2 ~> m2 s-2]. real, dimension(SZI_(G),SZJB_(G),SZK_(G)) :: & - inty_dza ! The change in inty_za through a layer [m2 s-2]. + inty_dza ! The change in inty_za through a layer [L2 T-2 ~> m2 s-2]. real :: p_ref(SZI_(G)) ! The pressure used to calculate the coordinate ! density, [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 [Pa]. - real :: g_Earth_z ! A scaled version of g_Earth [m2 Z-1 s-2 ~> m s-2]. - real :: I_gEarth ! The inverse of g_Earth_z [s2 Z m-2 ~> s2 m-1] + ! in roundoff and can be neglected [R L2 T-2 ~> Pa]. + real :: I_gEarth ! The inverse of GV%g_Earth [L2 Z L-2 ~> s2 m-1] real :: alpha_anom ! The in-situ specific volume, averaged over a - ! layer, less alpha_ref [m3 kg-1]. + ! layer, less alpha_ref [R-1 ~> 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. + 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 [m3 kg-1], that is used - ! to reduce the impact of truncation errors. - real :: rho_in_situ(SZI_(G)) ! The in situ density [kg m-3]. - real :: Pa_to_H ! A factor to convert from Pa to the thicknesss units (H). + real :: alpha_ref ! A reference specific volume [R-1 ~> m3 kg-1] that is used + ! to reduce the impact of truncation errors. + real :: rho_in_situ(SZI_(G)) ! The in situ density [R ~> kg m-3]. + real :: Pa_to_H ! A factor to convert from Pa to the thicknesss units (H) [H T2 R-1 L-12 ~> H Pa-1]. + real :: H_to_RL2_T2 ! A factor to convert from thicknesss units (H) to pressure units [R L2 T-2 H-1 ~> Pa H-1]. ! real :: oneatm = 101325.0 ! 1 atm in [Pa] = [kg m-1 s-2] real, parameter :: C1_6 = 1.0/6.0 integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz, nkmb @@ -193,15 +192,15 @@ subroutine PressureForce_AFV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p 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/(US%R_to_kg_m3*CS%Rho0) - g_Earth_z = US%L_T_to_m_s**2 * GV%g_Earth - I_gEarth = 1.0 / g_Earth_z + H_to_RL2_T2 = GV%g_Earth*GV%H_to_RZ + dp_neglect = GV%g_Earth*GV%H_to_RZ * GV%H_subroundoff + alpha_ref = 1.0 / CS%Rho0 + I_gEarth = 1.0 / GV%g_Earth 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) + p(i,j,1) = US%kg_m3_to_R*US%m_s_to_L_T**2*p_atm(i,j) enddo ; enddo else !$OMP parallel do default(shared) @@ -211,7 +210,7 @@ subroutine PressureForce_AFV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p 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) + p(i,j,K) = p(i,j,K-1) + H_to_RL2_T2 * h(i,j,k-1) enddo ; enddo ; enddo if (use_EOS) then @@ -263,13 +262,11 @@ subroutine PressureForce_AFV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p if (use_EOS) then 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, & + 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 + intx_dza(:,:,k), inty_dza(:,:,k), useMassWghtInterp=CS%useMassWghtInterp, & + SV_scale=US%R_to_kg_m3, pres_scale=US%R_to_kg_m3*US%L_T_to_m_s**2) elseif ( CS%Recon_Scheme == 2 ) then call MOM_error(FATAL, "PressureForce_AFV_nonBouss: "//& "int_spec_vol_dp_generic_ppm does not exist yet.") @@ -283,12 +280,13 @@ subroutine PressureForce_AFV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p 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) + useMassWghtInterp=CS%useMassWghtInterp, & + SV_scale=US%R_to_kg_m3, pres_scale=US%R_to_kg_m3*US%L_T_to_m_s**2) endif else - alpha_anom = 1.0/(US%R_to_kg_m3*GV%Rlay(k)) - alpha_ref + 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) + dp(i,j) = H_to_RL2_T2 * 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 @@ -312,7 +310,7 @@ subroutine PressureForce_AFV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p !$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) - g_Earth_z*G%bathyT(i,j) + 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) @@ -328,7 +326,7 @@ subroutine PressureForce_AFV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p call calc_tidal_forcing(CS%Time, SSH, e_tidal, G, CS%tides_CSp, m_to_Z=US%m_to_Z) !$OMP parallel do default(shared) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - za(i,j) = za(i,j) - g_Earth_z * e_tidal(i,j) + za(i,j) = za(i,j) - GV%g_Earth * e_tidal(i,j) enddo ; enddo endif @@ -337,19 +335,17 @@ subroutine PressureForce_AFV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p 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) + 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, scale=US%kg_m3_to_R, pres_scale=US%R_to_kg_m3*US%L_T_to_m_s**2) do i=Isq,Ieq+1 - dM(i,j) = (CS%GFS_scale - 1.0) * US%m_s_to_L_T**2 * & - (p(i,j,1)*(1.0/rho_in_situ(i) - alpha_ref) + za(i,j)) + 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) * US%m_s_to_L_T**2 * & - (p(i,j,1)*(1.0/(US%R_to_kg_m3*GV%Rlay(1)) - alpha_ref) + za(i,j)) + 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 @@ -374,28 +370,26 @@ subroutine PressureForce_AFV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p ! 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) + dp(i,j) = H_to_RL2_T2 * h(i,j,k) za(i,j) = za(i,j) - dza(i,j,k) enddo ; enddo !$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))) * & - (US%m_s_to_L_T**2 * 2.0*G%IdxCu(I,j) / & - ((dp(i,j) + dp(i+1,j)) + dp_neglect)) + 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 !$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))) * & - (US%m_s_to_L_T**2 * 2.0*G%IdyCv(i,J) / & - ((dp(i,j) + dp(i,j+1)) + dp_neglect)) + (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 if (CS%GFS_scale < 1.0) then @@ -416,11 +410,11 @@ subroutine PressureForce_AFV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p endif if (present(eta)) then - Pa_to_H = 1.0 / GV%H_to_Pa + Pa_to_H = 1.0 / (GV%g_Earth * GV%H_to_RZ) 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. + eta(i,j) = (p(i,j,nz+1) - US%kg_m3_to_R*US%m_s_to_L_T**2*p_atm(i,j))*Pa_to_H ! eta has the same units as h. enddo ; enddo else !$OMP parallel do default(shared) diff --git a/src/core/MOM_PressureForce_blocked_AFV.F90 b/src/core/MOM_PressureForce_blocked_AFV.F90 index 60e1330aa6..34b3b8301d 100644 --- a/src/core/MOM_PressureForce_blocked_AFV.F90 +++ b/src/core/MOM_PressureForce_blocked_AFV.F90 @@ -117,7 +117,7 @@ subroutine PressureForce_blk_AFV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, !! calculate PFu and PFv [H ~> m or kg m-2], with any tidal !! contributions or compressibility compensation. ! Local variables - real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1) :: p ! Interface pressure [Pa]. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1) :: p ! Interface pressure [R L2 T-2 ~> 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 [degC]. @@ -125,53 +125,52 @@ subroutine PressureForce_blk_AFV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, ! than the mixed layer have the mixed layer's properties [ppt]. real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: & dza, & ! The change in geopotential anomaly between the top and bottom - ! of a layer [m2 s-2]. + ! of a layer [L2 T-2 ~> m2 s-2]. intp_dza ! The vertical integral in depth of the pressure anomaly less - ! the pressure anomaly at the top of the layer [Pa m2 s-2]. + ! the pressure anomaly at the top of the layer [R L4 T-4 ~> Pa m2 s-2]. real, dimension(SZI_(G),SZJ_(G)) :: & - dp, & ! The (positive) change in pressure across a layer [Pa]. + dp, & ! The (positive) change in pressure across a layer [R L2 T-2 ~> Pa]. SSH, & ! The sea surface height anomaly, in depth units [Z ~> m]. e_tidal, & ! The bottom geopotential anomaly due to tidal forces from ! astronomical sources and self-attraction and loading [Z ~> m]. dM, & ! The barotropic adjustment to the Montgomery potential to - ! account for a reduced gravity model [m2 s-2]. + ! account for a reduced gravity model [L2 T-2 ~> m2 s-2]. za ! The geopotential anomaly (i.e. g*e + alpha_0*pressure) at the - ! interface atop a layer [m2 s-2]. + ! interface atop a layer [L2 T-2 ~> 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 [Pa]. + dp_bk, & ! The (positive) change in pressure across a layer [R L2 T-2 ~> Pa]. za_bk ! The geopotential anomaly (i.e. g*e + alpha_0*pressure) at the - ! interface atop a layer [m2 s-2]. + ! interface atop a layer [L2 T-2 ~> m2 s-2]. real, dimension(SZI_(G)) :: Rho_cv_BL ! The coordinate potential density in the deepest variable ! density near-surface layer [R ~> 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]. + ! interface below a layer, divided by the grid spacing [L2 T-2 ~> m2 s-2]. real, dimension(SZIB_(G),SZJ_(G),SZK_(G)) :: & - intx_dza ! The change in intx_za through a layer [m2 s-2]. + intx_dza ! The change in intx_za through a layer [L2 T-2 ~> 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]. + ! interface below a layer, divided by the grid spacing [L2 T-2 ~> m2 s-2]. real, dimension(SZI_(G),SZJB_(G),SZK_(G)) :: & - inty_dza ! The change in inty_za through a layer [m2 s-2]. + inty_dza ! The change in inty_za through a layer [L2 T-2 ~> m2 s-2]. real :: p_ref(SZI_(G)) ! The pressure used to calculate the coordinate ! density [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 [Pa]. - real :: g_Earth_z ! A scaled version of g_Earth [m2 Z-1 s-2 ~> m s-2]. - real :: I_gEarth ! The inverse of g_Earth_z [s2 Z m-2 ~> s2 m-1] + real :: I_gEarth ! The inverse of GV%g_Earth [L2 Z L-2 ~> s2 m-1] real :: alpha_anom ! The in-situ specific volume, averaged over a - ! layer, less alpha_ref [m3 kg-1]. + ! layer, less alpha_ref [R-1 ~> 3 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. + 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 [m3 kg-1], that is used - ! to reduce the impact of truncation errors. - real :: rho_in_situ(SZI_(G)) ! The in situ density [kg m-3]. - real :: Pa_to_H ! A factor to convert from Pa to the thicknesss units (H). + real :: alpha_ref ! A reference specific volume [R-1 ~> m3 kg-1] that is used + ! to reduce the impact of truncation errors. + real :: rho_in_situ(SZI_(G)) ! The in situ density [R ~> kg m-3]. + real :: Pa_to_H ! A factor to convert from Pa to the thicknesss units (H) [H T2 R-1 L-12 ~> H Pa-1]. + real :: H_to_RL2_T2 ! A factor to convert from thicknesss units (H) to pressure units [R L2 T-2 H-1 ~> Pa H-1]. ! real :: oneatm = 101325.0 ! 1 atm in [Pa] = [kg m-1 s-2] real, parameter :: C1_6 = 1.0/6.0 integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz, nkmb @@ -189,15 +188,15 @@ subroutine PressureForce_blk_AFV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, 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/(US%R_to_kg_m3*CS%Rho0) - g_Earth_z = US%L_T_to_m_s**2 * GV%g_Earth - I_gEarth = 1.0 / g_Earth_z + H_to_RL2_T2 = GV%g_Earth*GV%H_to_RZ + dp_neglect = GV%g_Earth*GV%H_to_RZ * GV%H_subroundoff + alpha_ref = 1.0 / CS%Rho0 + I_gEarth = 1.0 / GV%g_Earth 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) + p(i,j,1) = US%kg_m3_to_R*US%m_s_to_L_T**2*p_atm(i,j) enddo ; enddo else !$OMP parallel do default(shared) @@ -207,7 +206,7 @@ subroutine PressureForce_blk_AFV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, 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) + p(i,j,K) = p(i,j,K-1) + H_to_RL2_T2 * h(i,j,k-1) enddo ; enddo ; enddo if (use_EOS) then @@ -249,11 +248,12 @@ subroutine PressureForce_blk_AFV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, 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) + useMassWghtInterp=CS%useMassWghtInterp, & + SV_scale=US%R_to_kg_m3, pres_scale=US%R_to_kg_m3*US%L_T_to_m_s**2) else - alpha_anom = 1.0/(US%R_to_kg_m3*GV%Rlay(k)) - alpha_ref + 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) + dp(i,j) = H_to_RL2_T2 * 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 @@ -277,7 +277,7 @@ subroutine PressureForce_blk_AFV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, !$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) - g_Earth_z*G%bathyT(i,j) + 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) @@ -293,7 +293,7 @@ subroutine PressureForce_blk_AFV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, call calc_tidal_forcing(CS%Time, SSH, e_tidal, G, CS%tides_CSp, m_to_Z=US%m_to_Z) !$OMP parallel do default(shared) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - za(i,j) = za(i,j) - g_Earth_z * e_tidal(i,j) + za(i,j) = za(i,j) - GV%g_Earth * e_tidal(i,j) enddo ; enddo endif @@ -302,19 +302,17 @@ subroutine PressureForce_blk_AFV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, 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) + 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, scale=US%kg_m3_to_R, pres_scale=US%R_to_kg_m3*US%L_T_to_m_s**2) do i=Isq,Ieq+1 - dM(i,j) = (CS%GFS_scale - 1.0) * & - US%m_s_to_L_T**2*(p(i,j,1)*(1.0/rho_in_situ(i) - alpha_ref) + za(i,j)) + 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) * & - US%m_s_to_L_T**2*(p(i,j,1)*(1.0/(US%R_to_kg_m3*GV%Rlay(1)) - alpha_ref) + za(i,j)) + 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 @@ -355,28 +353,26 @@ subroutine PressureForce_blk_AFV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, ! 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) + dp_bk(ib,jb) = H_to_RL2_T2*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))) * & - (US%m_s_to_L_T**2 * 2.0*G%IdxCu(I,j) / & - ((dp_bk(ib,jb) + dp_bk(ib+1,jb)) + dp_neglect)) + 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))) * & - (US%m_s_to_L_T**2 * 2.0*G%IdyCv(i,J) / & - ((dp_bk(ib,jb) + dp_bk(ib,jb+1)) + dp_neglect)) + 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 @@ -396,11 +392,11 @@ subroutine PressureForce_blk_AFV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, endif if (present(eta)) then - Pa_to_H = 1.0 / GV%H_to_Pa + Pa_to_H = 1.0 / (GV%g_Earth * GV%H_to_RZ) 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. + eta(i,j) = (p(i,j,nz+1) - US%kg_m3_to_R*US%m_s_to_L_T**2*p_atm(i,j))*Pa_to_H ! eta has the same units as h. enddo ; enddo else !$OMP parallel do default(shared) From 94f94ede612eeb3ed2b47cb10f3ea16774dfebd7 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Mon, 6 Apr 2020 19:45:32 -0400 Subject: [PATCH 149/316] Rescaled pressure in find_eta routines Rescaled the pressure used to calculate density integrals in find_eta_3d and find_eta_2d to [R L2 T-2] and used the new pres_scale and SV_scale arguments to int_specific_vol_dp. All answers are bitwise identical. --- src/core/MOM_interface_heights.F90 | 29 +++++++++++++++++------------ 1 file changed, 17 insertions(+), 12 deletions(-) diff --git a/src/core/MOM_interface_heights.F90 b/src/core/MOM_interface_heights.F90 index 8dbacf6798..06868b875f 100644 --- a/src/core/MOM_interface_heights.F90 +++ b/src/core/MOM_interface_heights.F90 @@ -47,12 +47,13 @@ subroutine find_eta_3d(h, tv, G, GV, US, eta, eta_bt, halo_size, eta_to_m) !! the units of eta to m; by default this is US%Z_to_m. ! Local variables - real :: p(SZI_(G),SZJ_(G),SZK_(G)+1) ! Hydrostatic pressure at each interface [Pa] + real :: p(SZI_(G),SZJ_(G),SZK_(G)+1) ! Hydrostatic pressure at each interface [R L2 T-2 ~> Pa] real :: dz_geo(SZI_(G),SZJ_(G),SZK_(G)) ! The change in geopotential height - ! across a layer [m2 s-2]. + ! across a layer [L2 T-2 ~> m2 s-2]. real :: dilate(SZI_(G)) ! non-dimensional dilation factor real :: htot(SZI_(G)) ! total thickness [H ~> m or kg m-2] - real :: I_gEarth + real :: I_gEarth ! The inverse of the gravitational acceleration times the + ! rescaling factor derived from eta_to_m [T2 Z L-2 ~> s2 m-1] real :: Z_to_eta, H_to_eta, H_to_rho_eta ! Unit conversion factors with obvious names. integer i, j, k, isv, iev, jsv, jev, nz, halo @@ -67,7 +68,7 @@ subroutine find_eta_3d(h, tv, G, GV, US, eta, eta_bt, halo_size, eta_to_m) Z_to_eta = 1.0 ; if (present(eta_to_m)) Z_to_eta = US%Z_to_m / eta_to_m H_to_eta = GV%H_to_Z * Z_to_eta H_to_rho_eta = GV%H_to_RZ * Z_to_eta - I_gEarth = Z_to_eta / (US%Z_to_m * GV%mks_g_Earth) + I_gEarth = Z_to_eta / GV%g_Earth !$OMP parallel default(shared) private(dilate,htot) !$OMP do @@ -99,13 +100,14 @@ subroutine find_eta_3d(h, tv, G, GV, US, eta, eta_bt, halo_size, eta_to_m) ! ### THIS SHOULD BE P_SURF, IF AVAILABLE. do i=isv,iev ; p(i,j,1) = 0.0 ; enddo do k=1,nz ; do i=isv,iev - p(i,j,K+1) = p(i,j,K) + GV%H_to_Pa*h(i,j,k) + p(i,j,K+1) = p(i,j,K) + GV%g_Earth*GV%H_to_RZ*h(i,j,k) enddo ; enddo enddo !$OMP do do k=1,nz call int_specific_vol_dp(tv%T(:,:,k), tv%S(:,:,k), p(:,:,K), p(:,:,K+1), & - 0.0, G%HI, tv%eqn_of_state, dz_geo(:,:,k), halo_size=halo) + 0.0, G%HI, tv%eqn_of_state, dz_geo(:,:,k), halo_size=halo, & + SV_scale=US%R_to_kg_m3, pres_scale=US%R_to_kg_m3*US%L_T_to_m_s**2) enddo !$OMP do do j=jsv,jev @@ -159,11 +161,12 @@ subroutine find_eta_2d(h, tv, G, GV, US, eta, eta_bt, halo_size, eta_to_m) !! the units of eta to m; by default this is US%Z_to_m. ! Local variables real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1) :: & - p ! The pressure at interfaces [Pa]. + p ! Hydrostatic pressure at each interface [R L2 T-2 ~> Pa] real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: & - dz_geo ! The change in geopotential height across a layer [m2 s-2]. + dz_geo ! The change in geopotential height across a layer [L2 T-2 ~> m2 s-2]. real :: htot(SZI_(G)) ! The sum of all layers' thicknesses [H ~> m or kg m-2]. - real :: I_gEarth + real :: I_gEarth ! The inverse of the gravitational acceleration times the + ! rescaling factor derived from eta_to_m [T2 Z L-2 ~> s2 m-1] real :: Z_to_eta, H_to_eta, H_to_rho_eta ! Unit conversion factors with obvious names. integer i, j, k, is, ie, js, je, nz, halo @@ -174,7 +177,7 @@ subroutine find_eta_2d(h, tv, G, GV, US, eta, eta_bt, halo_size, eta_to_m) Z_to_eta = 1.0 ; if (present(eta_to_m)) Z_to_eta = US%Z_to_m / eta_to_m H_to_eta = GV%H_to_Z * Z_to_eta H_to_rho_eta = GV%H_to_RZ * Z_to_eta - I_gEarth = Z_to_eta / (US%Z_to_m * GV%mks_g_Earth) + I_gEarth = Z_to_eta / GV%g_Earth !$OMP parallel default(shared) private(htot) !$OMP do @@ -196,16 +199,18 @@ subroutine find_eta_2d(h, tv, G, GV, US, eta, eta_bt, halo_size, eta_to_m) if (associated(tv%eqn_of_state)) then !$OMP do do j=js,je + ! ### THIS SHOULD BE P_SURF, IF AVAILABLE. do i=is,ie ; p(i,j,1) = 0.0 ; enddo do k=1,nz ; do i=is,ie - p(i,j,k+1) = p(i,j,k) + GV%H_to_Pa*h(i,j,k) + p(i,j,k+1) = p(i,j,k) + GV%g_Earth*GV%H_to_RZ*h(i,j,k) enddo ; enddo enddo !$OMP do do k = 1, nz call int_specific_vol_dp(tv%T(:,:,k), tv%S(:,:,k), p(:,:,k), p(:,:,k+1), 0.0, & - G%HI, tv%eqn_of_state, dz_geo(:,:,k), halo_size=halo) + G%HI, tv%eqn_of_state, dz_geo(:,:,k), halo_size=halo, & + SV_scale=US%R_to_kg_m3, pres_scale=US%R_to_kg_m3*US%L_T_to_m_s**2) enddo !$OMP do do j=js,je ; do k=1,nz ; do i=is,ie From f29e32a4492fdeff8d540d5d2240bef6373e5ab0 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Mon, 6 Apr 2020 19:46:25 -0400 Subject: [PATCH 150/316] Rescaled pressure in calc_isoneutral_slopes Rescaled the pressure used in calls to calculate_density_derivs to [R L2 T-2] in calculate_density_derivs. All answers are bitwise identical. --- src/core/MOM_isopycnal_slopes.F90 | 17 +++++++++-------- 1 file changed, 9 insertions(+), 8 deletions(-) diff --git a/src/core/MOM_isopycnal_slopes.F90 b/src/core/MOM_isopycnal_slopes.F90 index fc60d54f10..11ae7baa26 100644 --- a/src/core/MOM_isopycnal_slopes.F90 +++ b/src/core/MOM_isopycnal_slopes.F90 @@ -55,7 +55,7 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, & ! in massless layers filled vertically by diffusion. ! Rho ! Density itself, when a nonlinear equation of state is not in use [R ~> kg m-3]. real, dimension(SZI_(G), SZJ_(G), SZK_(G)+1) :: & - pres ! The pressure at an interface [Pa]. + pres ! The pressure at an interface [R L2 T-2 ~> Pa]. real, dimension(SZIB_(G)) :: & drho_dT_u, & ! The derivative of density with temperature at u points [R degC-1 ~> kg m-3 degC-1]. drho_dS_u ! The derivative of density with salinity at u points [R ppt-1 ~> kg m-3 ppt-1]. @@ -65,11 +65,11 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, & real, dimension(SZIB_(G)) :: & T_u, & ! Temperature on the interface at the u-point [degC]. S_u, & ! Salinity on the interface at the u-point [ppt]. - pres_u ! Pressure on the interface at the u-point [Pa]. + pres_u ! Pressure on the interface at the u-point [R L2 T-2 ~> Pa]. real, dimension(SZI_(G)) :: & T_v, & ! Temperature on the interface at the v-point [degC]. S_v, & ! Salinity on the interface at the v-point [ppt]. - pres_v ! Pressure on the interface at the v-point [Pa]. + pres_v ! Pressure on the interface at the v-point [R L2 T-2 ~> Pa]. real :: drdiA, drdiB ! Along layer zonal- and meridional- potential density real :: drdjA, drdjB ! gradients in the layers above (A) and below (B) the ! interface times the grid spacing [R ~> kg m-3]. @@ -147,12 +147,11 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, & !$OMP parallel do default(shared) do j=js-1,je+1 ; do i=is-1,ie+1 pres(i,j,1) = 0.0 ! ### This should be atmospheric pressure. - pres(i,j,2) = pres(i,j,1) + GV%H_to_Pa*h(i,j,1) enddo ; enddo !$OMP parallel do default(shared) do j=js-1,je+1 - do k=2,nz ; do i=is-1,ie+1 - pres(i,j,K+1) = pres(i,j,K) + GV%H_to_Pa*h(i,j,k) + do k=1,nz ; do i=is-1,ie+1 + pres(i,j,K+1) = pres(i,j,K) + GV%g_Earth * GV%H_to_RZ * h(i,j,k) enddo ; enddo enddo @@ -177,7 +176,8 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, & S_u(I) = 0.25*((S(i,j,k) + S(i+1,j,k)) + (S(i,j,k-1) + S(i+1,j,k-1))) enddo call calculate_density_derivs(T_u, S_u, pres_u, drho_dT_u, & - drho_dS_u, (is-IsdB+1)-1, ie-is+2, tv%eqn_of_state, scale=US%kg_m3_to_R) + drho_dS_u, (is-IsdB+1)-1, ie-is+2, tv%eqn_of_state, scale=US%kg_m3_to_R, & + pres_scale=US%R_to_kg_m3*US%L_T_to_m_s**2) endif do I=is-1,ie @@ -263,7 +263,8 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, & S_v(i) = 0.25*((S(i,j,k) + S(i,j+1,k)) + (S(i,j,k-1) + S(i,j+1,k-1))) enddo call calculate_density_derivs(T_v, S_v, pres_v, drho_dT_v, & - drho_dS_v, is, ie-is+1, tv%eqn_of_state, scale=US%kg_m3_to_R) + drho_dS_v, is, ie-is+1, tv%eqn_of_state, scale=US%kg_m3_to_R, & + pres_scale=US%R_to_kg_m3*US%L_T_to_m_s**2) endif do i=is,ie if (use_EOS) then From efbbd317b0c964b52b909b3f1a2f1681b2b3f6cb Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Mon, 6 Apr 2020 19:47:54 -0400 Subject: [PATCH 151/316] Rescaled pressures in calculate_vertical_integrals Rescaled pressures to [R L2 T-2] in calculate_vertical_integrals for improved dimensional consistency testing. All answers are bitwise identical. --- src/diagnostics/MOM_diagnostics.F90 | 22 +++++++++++----------- 1 file changed, 11 insertions(+), 11 deletions(-) diff --git a/src/diagnostics/MOM_diagnostics.F90 b/src/diagnostics/MOM_diagnostics.F90 index 84c4011718..63e664a0ed 100644 --- a/src/diagnostics/MOM_diagnostics.F90 +++ b/src/diagnostics/MOM_diagnostics.F90 @@ -785,11 +785,11 @@ subroutine calculate_vertical_integrals(h, tv, p_surf, G, GV, US, CS) ! (rho*dz for col_mass) or reference density (Rho_0*dz for mass_wt). btm_pres,&! The pressure at the ocean bottom, or CMIP variable 'pbo'. ! This is the column mass multiplied by gravity plus the pressure - ! at the ocean surface [Pa]. - dpress, & ! Change in hydrostatic pressure across a layer [Pa]. + ! at the ocean surface [R L2 T-2 ~> Pa]. + dpress, & ! Change in hydrostatic pressure across a layer [R L2 T-2 ~> Pa]. tr_int ! vertical integral of a tracer times density, ! (Rho_0 in a Boussinesq model) [TR kg m-2]. - real :: IG_Earth ! Inverse of gravitational acceleration [s2 Z m-2 ~> s2 m-1]. + real :: IG_Earth ! Inverse of gravitational acceleration [T2 Z L-2 ~> s2 m-1]. integer :: i, j, k, is, ie, js, je, nz is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke @@ -831,7 +831,7 @@ subroutine calculate_vertical_integrals(h, tv, p_surf, G, GV, US, CS) do j=js,je ; do i=is,ie ; mass(i,j) = 0.0 ; enddo ; enddo if (GV%Boussinesq) then if (associated(tv%eqn_of_state)) then - IG_Earth = 1.0 / (US%Z_to_m*GV%mks_g_Earth) + IG_Earth = 1.0 / GV%g_Earth ! do j=js,je ; do i=is,ie ; z_bot(i,j) = -P_SURF(i,j)/GV%H_to_Pa ; enddo ; enddo do j=G%jscB,G%jecB+1 ; do i=G%iscB,G%iecB+1 z_bot(i,j) = 0.0 @@ -841,11 +841,11 @@ subroutine calculate_vertical_integrals(h, tv, p_surf, G, GV, US, CS) z_top(i,j) = z_bot(i,j) z_bot(i,j) = z_top(i,j) - GV%H_to_Z*h(i,j,k) enddo ; enddo - call int_density_dz(tv%T(:,:,k), tv%S(:,:,k), & - z_top, z_bot, 0.0, US%R_to_kg_m3*GV%Rho0, GV%mks_g_Earth*US%Z_to_m, & - G%HI, G%HI, tv%eqn_of_state, dpress) + call int_density_dz(tv%T(:,:,k), tv%S(:,:,k), z_top, z_bot, 0.0, GV%Rho0, GV%g_Earth, & + G%HI, G%HI, tv%eqn_of_state, dpress, rho_scale=US%kg_m3_to_R, & + pres_scale=US%R_to_kg_m3*US%L_T_to_m_s**2) do j=js,je ; do i=is,ie - mass(i,j) = mass(i,j) + dpress(i,j) * US%kg_m3_to_R*IG_Earth + mass(i,j) = mass(i,j) + dpress(i,j) * IG_Earth enddo ; enddo enddo else @@ -867,9 +867,9 @@ subroutine calculate_vertical_integrals(h, tv, p_surf, G, GV, US, CS) ! 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) = US%RZ_to_kg_m2*mass(i,j) * GV%mks_g_Earth + btm_pres(i,j) = GV%g_Earth * mass(i,j) if (associated(p_surf)) then - btm_pres(i,j) = btm_pres(i,j) + p_surf(i,j) + btm_pres(i,j) = btm_pres(i,j) + US%kg_m3_to_R*US%m_s_to_L_T**2*p_surf(i,j) endif enddo ; enddo call post_data(CS%id_pbo, btm_pres, CS%diag) @@ -1732,7 +1732,7 @@ subroutine MOM_diagnostics_init(MIS, ADp, CDp, Time, G, GV, US, param_file, diag 'The height of the water column', 'm', conversion=US%Z_to_m) CS%id_pbo = register_diag_field('ocean_model', 'pbo', diag%axesT1, Time, & long_name='Sea Water Pressure at Sea Floor', standard_name='sea_water_pressure_at_sea_floor', & - units='Pa') + units='Pa', conversion=US%R_to_kg_m3*US%L_T_to_m_s**2) call set_dependent_diagnostics(MIS, ADp, CDp, G, CS) From 1a6411f0c0a83e35b1613e0e829b408d0bf09fc8 Mon Sep 17 00:00:00 2001 From: Mariana Vertenstein Date: Mon, 6 Apr 2020 20:52:33 -0600 Subject: [PATCH 152/316] added changes to unify cap with EMC changes --- config_src/nuopc_driver/mom_cap.F90 | 1008 ++++++++++++++++++++------- 1 file changed, 745 insertions(+), 263 deletions(-) diff --git a/config_src/nuopc_driver/mom_cap.F90 b/config_src/nuopc_driver/mom_cap.F90 index ba3c3e80d8..26cff18324 100644 --- a/config_src/nuopc_driver/mom_cap.F90 +++ b/config_src/nuopc_driver/mom_cap.F90 @@ -72,6 +72,9 @@ module MOM_cap_mod use ESMF, only: ESMF_ArrayCreate use ESMF, only: ESMF_RC_FILE_OPEN, ESMF_RC_FILE_READ, ESMF_RC_FILE_WRITE use ESMF, only: ESMF_VMBroadcast +use ESMF, only: ESMF_AlarmCreate, ESMF_ClockGetAlarmList, ESMF_AlarmList_Flag +use ESMF, only: ESMF_AlarmGet, ESMF_AlarmIsCreated, ESMF_ALARMLIST_ALL, ESMF_AlarmIsEnabled +use ESMF, only: ESMF_STATEITEM_NOTFOUND, ESMF_FieldWrite use ESMF, only: operator(==), operator(/=), operator(+), operator(-) ! TODO ESMF_GridCompGetInternalState does not have an explicit Fortran interface. @@ -83,16 +86,17 @@ module MOM_cap_mod use NUOPC, only: NUOPC_Advertise, NUOPC_SetAttribute, NUOPC_IsUpdated, NUOPC_Write use NUOPC, only: NUOPC_IsConnected, NUOPC_Realize, NUOPC_CompAttributeSet use NUOPC_Model, only: NUOPC_ModelGet -use NUOPC_Model, & - model_routine_SS => SetServices, & - model_label_Advance => label_Advance, & - model_label_DataInitialize => label_DataInitialize, & - model_label_SetRunClock => label_SetRunClock, & - model_label_Finalize => label_Finalize +use NUOPC_Model, only: model_routine_SS => SetServices +use NUOPC_Model, only: model_label_Advance => label_Advance +use NUOPC_Model, only: model_label_DataInitialize => label_DataInitialize +use NUOPC_Model, only: model_label_SetRunClock => label_SetRunClock +use NUOPC_Model, only: model_label_Finalize => label_Finalize +use NUOPC_Model, only: SetVM implicit none; private public SetServices +public SetVM !> Internal state type with pointers to three types defined by MOM. type ocean_internalstate_type @@ -260,54 +264,95 @@ subroutine InitializeP0(gcomp, importState, exportState, clock, rc) ! Switch to IPDv03 by filtering all other phaseMap entries call NUOPC_CompFilterPhaseMap(gcomp, ESMF_METHOD_INITIALIZE, & acceptStringList=(/"IPDv03p"/), rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return write_diagnostics = .false. call NUOPC_CompAttributeGet(gcomp, name="DumpFields", value=value, & isPresent=isPresent, isSet=isSet, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return if (isPresent .and. isSet) write_diagnostics=(trim(value)=="true") write(logmsg,*) write_diagnostics - call ESMF_LogWrite('MOM_cap:DumpFields = '//trim(logmsg), ESMF_LOGMSG_INFO) + call ESMF_LogWrite('MOM_cap:DumpFields = '//trim(logmsg), ESMF_LOGMSG_INFO, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return overwrite_timeslice = .false. call NUOPC_CompAttributeGet(gcomp, name="OverwriteSlice", value=value, & isPresent=isPresent, isSet=isSet, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return if (isPresent .and. isSet) overwrite_timeslice=(trim(value)=="true") write(logmsg,*) overwrite_timeslice - call ESMF_LogWrite('MOM_cap:OverwriteSlice = '//trim(logmsg), ESMF_LOGMSG_INFO) + call ESMF_LogWrite('MOM_cap:OverwriteSlice = '//trim(logmsg), ESMF_LOGMSG_INFO, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return profile_memory = .false. call NUOPC_CompAttributeGet(gcomp, name="ProfileMemory", value=value, & isPresent=isPresent, isSet=isSet, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return if (isPresent .and. isSet) profile_memory=(trim(value)=="true") write(logmsg,*) profile_memory - call ESMF_LogWrite('MOM_cap:ProfileMemory = '//trim(logmsg), ESMF_LOGMSG_INFO) + call ESMF_LogWrite('MOM_cap:ProfileMemory = '//trim(logmsg), ESMF_LOGMSG_INFO, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return grid_attach_area = .false. call NUOPC_CompAttributeGet(gcomp, name="GridAttachArea", value=value, & isPresent=isPresent, isSet=isSet, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return if (isPresent .and. isSet) grid_attach_area=(trim(value)=="true") write(logmsg,*) grid_attach_area - call ESMF_LogWrite('MOM_cap:GridAttachArea = '//trim(logmsg), ESMF_LOGMSG_INFO) + call ESMF_LogWrite('MOM_cap:GridAttachArea = '//trim(logmsg), ESMF_LOGMSG_INFO, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return scalar_field_name = "" call NUOPC_CompAttributeGet(gcomp, name="ScalarFieldName", value=value, & isPresent=isPresent, isSet=isSet, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return if (isPresent .and. isSet) then scalar_field_name = trim(value) - call ESMF_LogWrite('MOM_cap:ScalarFieldName = '//trim(scalar_field_name), ESMF_LOGMSG_INFO) + call ESMF_LogWrite('MOM_cap:ScalarFieldName = '//trim(scalar_field_name), ESMF_LOGMSG_INFO, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return endif scalar_field_count = 0 call NUOPC_CompAttributeGet(gcomp, name="ScalarFieldCount", value=value, & isPresent=isPresent, isSet=isSet, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return if (isPresent .and. isSet) then read(value, '(i)', iostat=iostat) scalar_field_count if (iostat /= 0) then @@ -317,13 +362,20 @@ subroutine InitializeP0(gcomp, importState, exportState, clock, rc) return endif write(logmsg,*) scalar_field_count - call ESMF_LogWrite('MOM_cap:ScalarFieldCount = '//trim(logmsg), ESMF_LOGMSG_INFO) + call ESMF_LogWrite('MOM_cap:ScalarFieldCount = '//trim(logmsg), ESMF_LOGMSG_INFO, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return endif scalar_field_idx_grid_nx = 0 call NUOPC_CompAttributeGet(gcomp, name="ScalarFieldIdxGridNX", value=value, & isPresent=isPresent, isSet=isSet, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return if (isPresent .and. isSet) then read(value, '(i)', iostat=iostat) scalar_field_idx_grid_nx if (iostat /= 0) then @@ -333,13 +385,20 @@ subroutine InitializeP0(gcomp, importState, exportState, clock, rc) return endif write(logmsg,*) scalar_field_idx_grid_nx - call ESMF_LogWrite('MOM_cap:ScalarFieldIdxGridNX = '//trim(logmsg), ESMF_LOGMSG_INFO) + call ESMF_LogWrite('MOM_cap:ScalarFieldIdxGridNX = '//trim(logmsg), ESMF_LOGMSG_INFO, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return endif scalar_field_idx_grid_ny = 0 call NUOPC_CompAttributeGet(gcomp, name="ScalarFieldIdxGridNY", value=value, & isPresent=isPresent, isSet=isSet, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return if (isPresent .and. isSet) then read(value, '(i)', iostat=iostat) scalar_field_idx_grid_ny if (iostat /= 0) then @@ -349,7 +408,11 @@ subroutine InitializeP0(gcomp, importState, exportState, clock, rc) return endif write(logmsg,*) scalar_field_idx_grid_ny - call ESMF_LogWrite('MOM_cap:ScalarFieldIdxGridNY = '//trim(logmsg), ESMF_LOGMSG_INFO) + call ESMF_LogWrite('MOM_cap:ScalarFieldIdxGridNY = '//trim(logmsg), ESMF_LOGMSG_INFO, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return endif end subroutine @@ -400,7 +463,7 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) integer :: userRc integer :: localPet integer :: iostat - integer :: readunit + integer :: readunit character(len=512) :: restartfile ! Path/Name of restart file character(len=*), parameter :: subname='(MOM_cap:InitializeAdvertise)' character(len=32) :: calendar @@ -408,7 +471,11 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) rc = ESMF_SUCCESS - call ESMF_LogWrite(subname//' enter', ESMF_LOGMSG_INFO) + call ESMF_LogWrite(subname//' enter', ESMF_LOGMSG_INFO, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return allocate(Ice_ocean_boundary) !allocate(ocean_state) ! ocean_model_init allocate this pointer @@ -419,19 +486,34 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) ocean_internalstate%ptr%ocean_state_type_ptr => ocean_state call ESMF_VMGetCurrent(vm, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return ! bail out call ESMF_VMGet(VM, mpiCommunicator=mpi_comm_mom, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return ! bail out call ESMF_ClockGet(CLOCK, currTIME=MyTime, TimeStep=TINT, RC=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return ! bail out call ESMF_TimeGet (MyTime, YY=YEAR, MM=MONTH, DD=DAY, H=HOUR, M=MINUTE, S=SECOND, RC=rc ) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return ! bail out CALL ESMF_TimeIntervalGet(TINT, S=DT_OCEAN, RC=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return ! bail out call fms_init(mpi_comm_mom) call constants_init @@ -441,7 +523,10 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) if (cesm_coupled) then call NUOPC_CompAttributeGet(gcomp, name="calendar", value=cvalue, & isPresent=isPresent, isSet=isSet, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return ! bail out if (isPresent .and. isSet) then read(cvalue,*) calendar select case (trim(calendar)) @@ -475,10 +560,16 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) ! get start/reference time call ESMF_ClockGet(CLOCK, refTime=MyTime, RC=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return ! bail out call ESMF_TimeGet (MyTime, YY=YEAR, MM=MONTH, DD=DAY, H=HOUR, M=MINUTE, S=SECOND, RC=rc ) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return ! bail out time0 = set_date (YEAR,MONTH,DAY,HOUR,MINUTE,SECOND) @@ -494,15 +585,27 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) if (is_root_pe()) then call NUOPC_CompAttributeGet(gcomp, name="diro", & isPresent=isPresentDiro, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return call NUOPC_CompAttributeGet(gcomp, name="logfile", & isPresent=isPresentLogfile, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return if (isPresentDiro .and. isPresentLogfile) then - call NUOPC_CompAttributeGet(gcomp, name="diro", value=diro, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return - call NUOPC_CompAttributeGet(gcomp, name="logfile", value=logfile, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + call NUOPC_CompAttributeGet(gcomp, name="diro", value=diro, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return + call NUOPC_CompAttributeGet(gcomp, name="logfile", value=logfile, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return open(newunit=logunit,file=trim(diro)//"/"//trim(logfile)) else logunit = output_unit @@ -514,11 +617,19 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) starttype = "" call NUOPC_CompAttributeGet(gcomp, name='start_type', value=cvalue, & isPresent=isPresent, isSet=isSet, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return if (isPresent .and. isSet) then read(cvalue,*) starttype else - call ESMF_LogWrite('MOM_cap:start_type unset - using input.nml for restart option', ESMF_LOGMSG_INFO) + call ESMF_LogWrite('MOM_cap:start_type unset - using input.nml for restart option', & + ESMF_LOGMSG_INFO, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return endif runtype = "" @@ -536,7 +647,11 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) endif if (len_trim(runtype) > 0) then - call ESMF_LogWrite('MOM_cap:startup = '//trim(runtype), ESMF_LOGMSG_INFO) + call ESMF_LogWrite('MOM_cap:startup = '//trim(runtype), ESMF_LOGMSG_INFO, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return endif restartfile = "" @@ -555,26 +670,26 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) if (localPet == 0) then ! this hard coded for rpointer.ocn right now - open(newunit=readunit, file='rpointer.ocn', form='formatted', status='old', iostat=iostat) - if (iostat /= 0) then - call ESMF_LogSetError(ESMF_RC_FILE_OPEN, msg=subname//' ERROR opening rpointer.ocn', & - line=__LINE__, file=u_FILE_u, rcToReturn=rc) - return - endif - read(readunit,'(a)', iostat=iostat) restartfile - if (iostat /= 0) then - call ESMF_LogSetError(ESMF_RC_FILE_READ, msg=subname//' ERROR reading rpointer.ocn', & - line=__LINE__, file=u_FILE_u, rcToReturn=rc) - return - endif - close(readunit) - endif - ! broadcast attribute set on master task to all tasks - call ESMF_VMBroadcast(vm, restartfile, count=ESMF_MAXSTR-1, rootPet=0, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return - else - call ESMF_LogWrite('MOM_cap: restart requested, use input.nml', ESMF_LOGMSG_WARNING) - endif + open(newunit=readunit, file='rpointer.ocn', form='formatted', status='old', iostat=iostat) + if (iostat /= 0) then + call ESMF_LogSetError(ESMF_RC_FILE_OPEN, msg=subname//' ERROR opening rpointer.ocn', & + line=__LINE__, file=u_FILE_u, rcToReturn=rc) + return + endif + read(readunit,'(a)', iostat=iostat) restartfile + if (iostat /= 0) then + call ESMF_LogSetError(ESMF_RC_FILE_READ, msg=subname//' ERROR reading rpointer.ocn', & + line=__LINE__, file=u_FILE_u, rcToReturn=rc) + return + endif + close(readunit) + endif + ! broadcast attribute set on master task to all tasks + call ESMF_VMBroadcast(vm, restartfile, count=ESMF_MAXSTR-1, rootPet=0, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + else + call ESMF_LogWrite('MOM_cap: restart requested, use input.nml', ESMF_LOGMSG_WARNING) + endif endif @@ -782,7 +897,10 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) !---------------------------------------------------------------------------- call ESMF_GridCompGetInternalState(gcomp, ocean_internalstate, rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return ! bail out Ice_ocean_boundary => ocean_internalstate%ptr%ice_ocean_boundary_type_ptr ocean_public => ocean_internalstate%ptr%ocean_public_type_ptr @@ -793,9 +911,16 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) !---------------------------------------------------------------------------- call ESMF_VMGetCurrent(vm, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return ! bail out + call ESMF_VMGet(vm, petCount=npet, mpiCommunicator=mpicom, localPet=localPet, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return ! bail out !--------------------------------- ! global mom grid size @@ -803,7 +928,11 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) call mpp_get_global_domain(ocean_public%domain, xsize=nxg, ysize=nyg) write(tmpstr,'(a,2i6)') subname//' nxg,nyg = ',nxg,nyg - call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO) + call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return ! bail out !--------------------------------- ! number of tiles per PET, assumed to be 1, and number of pes (tiles) total @@ -812,11 +941,19 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) ntiles=mpp_get_ntile_count(ocean_public%domain) ! this is tiles on this pe if (ntiles /= 1) then rc = ESMF_FAILURE - call ESMF_LogWrite(subname//' ntiles must be 1', ESMF_LOGMSG_ERROR) + call ESMF_LogWrite(subname//' ntiles must be 1', ESMF_LOGMSG_ERROR, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return endif ntiles=mpp_get_domain_npes(ocean_public%domain) write(tmpstr,'(a,1i6)') subname//' ntiles = ',ntiles - call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO) + call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return !--------------------------------- ! get start and end indices of each tile and their PET @@ -828,7 +965,11 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) if (debug > 0) then do n = 1,ntiles write(tmpstr,'(a,6i6)') subname//' tiles ',n,pe(n),xb(n),xe(n),yb(n),ye(n) - call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO) + call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return enddo endif @@ -861,14 +1002,23 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) enddo DistGrid = ESMF_DistGridCreate(arbSeqIndexList=gindex, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return ! read in the mesh call NUOPC_CompAttributeGet(gcomp, name='mesh_ocn', value=cvalue, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return EMeshTemp = ESMF_MeshCreate(filename=trim(cvalue), fileformat=ESMF_FILEFORMAT_ESMFMESH, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return if (localPet == 0) then write(logunit,*)'mesh file for mom6 domain is ',trim(cvalue) @@ -876,11 +1026,17 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) ! recreate the mesh using the above distGrid EMesh = ESMF_MeshCreate(EMeshTemp, elementDistgrid=Distgrid, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return ! Check for consistency of lat, lon and mask between mesh and mom6 grid call ESMF_MeshGet(Emesh, spatialDim=spatialDim, numOwnedElements=numOwnedElements, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return allocate(ownedElemCoords(spatialDim*numOwnedElements)) allocate(lonMesh(numOwnedElements), lon(numOwnedElements)) @@ -898,10 +1054,15 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) end do elemMaskArray = ESMF_ArrayCreate(Distgrid, maskMesh, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return - + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return call ESMF_MeshGet(Emesh, elemMaskArray=elemMaskArray, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return call mpp_get_compute_domain(ocean_public%domain, isc, iec, jsc, jec) n = 0 @@ -948,10 +1109,16 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) deallocate(maskMesh, mask) ! realize the import and export fields using the mesh call MOM_RealizeFields(importState, fldsToOcn_num, fldsToOcn, "Ocn import", mesh=Emesh, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return call MOM_RealizeFields(exportState, fldsFrOcn_num, fldsFrOcn, "Ocn export", mesh=Emesh, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return else if (geomtype == ESMF_GEOMTYPE_GRID) then @@ -973,16 +1140,19 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) deBlockList(2,2,n) = ye(n) petMap(n) = pe(n) ! write(tmpstr,'(a,3i8)') subname//' iglo = ',n,deBlockList(1,1,n),deBlockList(1,2,n) - ! call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO) + ! call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO, rc=rc) ! write(tmpstr,'(a,3i8)') subname//' jglo = ',n,deBlockList(2,1,n),deBlockList(2,2,n) - ! call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO) + ! call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO, rc=rc) ! write(tmpstr,'(a,2i8)') subname//' pe = ',n,petMap(n) - ! call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO) + ! call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO, rc=rc) !--- assume a tile with starting index of 1 has an equivalent wraparound tile on the other side enddo delayout = ESMF_DELayoutCreate(petMap, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return ! bail out ! rsd this assumes tripole grid, but sometimes in CESM a bipole ! grid is used -- need to introduce conditional logic here @@ -993,12 +1163,18 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) call ESMF_DistGridConnectionSet(connectionList(1), tileIndexA=1, & tileIndexB=1, positionVector=(/nxg+1, 2*nyg+1/), & orientationVector=(/-1, -2/), rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return ! bail out ! periodic boundary condition along first dimension call ESMF_DistGridConnectionSet(connectionList(2), tileIndexA=1, & tileIndexB=1, positionVector=(/nxg, 0/), rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return distgrid = ESMF_DistGridCreate(minIndex=(/1,1/), maxIndex=(/nxg,nyg/), & ! indexflag = ESMF_INDEX_DELOCAL, & @@ -1007,7 +1183,10 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) delayout=delayout, & connectionList=connectionList, & rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return deallocate(xb,xe,yb,ye,pe) deallocate(connectionList) @@ -1016,18 +1195,32 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) deallocate(petMap) call ESMF_DistGridGet(distgrid=distgrid, localDE=0, elementCount=cnt, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return allocate(indexList(cnt)) write(tmpstr,'(a,i8)') subname//' distgrid cnt= ',cnt - call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO) + call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return call ESMF_DistGridGet(distgrid=distgrid, localDE=0, seqIndexList=indexList, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return write(tmpstr,'(a,4i8)') subname//' distgrid list= ',& indexList(1),indexList(cnt),minval(indexList), maxval(indexList) - call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO) + call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return deallocate(IndexList) @@ -1037,55 +1230,91 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) gridEdgeLWidth=(/0,0/), gridEdgeUWidth=(/0,1/), & coordSys = ESMF_COORDSYS_SPH_DEG, & rc = rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return + call ESMF_GridAddCoord(gridIn, staggerLoc=ESMF_STAGGERLOC_CENTER, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return call ESMF_GridAddCoord(gridIn, staggerLoc=ESMF_STAGGERLOC_CORNER, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return call ESMF_GridAddItem(gridIn, itemFlag=ESMF_GRIDITEM_MASK, itemTypeKind=ESMF_TYPEKIND_I4, & staggerLoc=ESMF_STAGGERLOC_CENTER, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return ! Attach area to the Grid optionally. By default the cell areas are computed. if(grid_attach_area) then call ESMF_GridAddItem(gridIn, itemFlag=ESMF_GRIDITEM_AREA, itemTypeKind=ESMF_TYPEKIND_R8, & staggerLoc=ESMF_STAGGERLOC_CENTER, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return + endif call ESMF_GridGetCoord(gridIn, coordDim=1, & staggerloc=ESMF_STAGGERLOC_CENTER, & farrayPtr=dataPtr_xcen, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return call ESMF_GridGetCoord(gridIn, coordDim=2, & staggerloc=ESMF_STAGGERLOC_CENTER, & farrayPtr=dataPtr_ycen, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return + call ESMF_GridGetCoord(gridIn, coordDim=1, & staggerloc=ESMF_STAGGERLOC_CORNER, & farrayPtr=dataPtr_xcor, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return call ESMF_GridGetCoord(gridIn, coordDim=2, & staggerloc=ESMF_STAGGERLOC_CORNER, & farrayPtr=dataPtr_ycor, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return call ESMF_GridGetItem(gridIn, itemflag=ESMF_GRIDITEM_MASK, & staggerloc=ESMF_STAGGERLOC_CENTER, & farrayPtr=dataPtr_mask, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return if(grid_attach_area) then call ESMF_GridGetItem(gridIn, itemflag=ESMF_GRIDITEM_AREA, & staggerloc=ESMF_STAGGERLOC_CENTER, & farrayPtr=dataPtr_area, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return endif ! load up area, mask, center and corner values @@ -1108,13 +1337,13 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) ubnd4 = ubound(dataPtr_xcor,2) write(tmpstr,*) subname//' iscjsc = ',isc,iec,jsc,jec - call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO) + call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO, rc=rc) write(tmpstr,*) subname//' lbub12 = ',lbnd1,ubnd1,lbnd2,ubnd2 - call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO) + call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO, rc=rc) write(tmpstr,*) subname//' lbub34 = ',lbnd3,ubnd3,lbnd4,ubnd4 - call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO) + call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO, rc=rc) if (iec-isc /= ubnd1-lbnd1 .or. jec-jsc /= ubnd2-lbnd2) then call ESMF_LogSetError(ESMF_RC_ARG_BAD, & @@ -1153,32 +1382,38 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) enddo write(tmpstr,*) subname//' mask = ',minval(dataPtr_mask),maxval(dataPtr_mask) - call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO) + call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO, rc=rc) if(grid_attach_area) then write(tmpstr,*) subname//' area = ',minval(dataPtr_area),maxval(dataPtr_area) - call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO) + call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO, rc=rc) endif write(tmpstr,*) subname//' xcen = ',minval(dataPtr_xcen),maxval(dataPtr_xcen) - call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO) + call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO, rc=rc) write(tmpstr,*) subname//' ycen = ',minval(dataPtr_ycen),maxval(dataPtr_ycen) - call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO) + call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO, rc=rc) write(tmpstr,*) subname//' xcor = ',minval(dataPtr_xcor),maxval(dataPtr_xcor) - call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO) + call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO, rc=rc) write(tmpstr,*) subname//' ycor = ',minval(dataPtr_ycor),maxval(dataPtr_ycor) - call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO) + call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO, rc=rc) gridOut = gridIn ! for now out same as in call MOM_RealizeFields(importState, fldsToOcn_num, fldsToOcn, "Ocn import", grid=gridIn, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return call MOM_RealizeFields(exportState, fldsFrOcn_num, fldsFrOcn, "Ocn export", grid=gridOut, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return endif @@ -1189,11 +1424,18 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) if (len_trim(scalar_field_name) > 0) then call State_SetScalar(dble(nxg),scalar_field_idx_grid_nx, exportState, localPet, & scalar_field_name, scalar_field_count, rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return call State_SetScalar(dble(nyg),scalar_field_idx_grid_ny, exportState, localPet, & scalar_field_name, scalar_field_count, rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return + endif !--------------------------------- @@ -1225,12 +1467,17 @@ subroutine DataInitialize(gcomp, rc) ! local variables type(ESMF_Clock) :: clock type(ESMF_State) :: importState, exportState + type(ESMF_Time) :: currTime + type(ESMF_TimeInterval) :: timeStep + type(ESMF_StateItem_Flag) :: itemType type (ocean_public_type), pointer :: ocean_public => NULL() type (ocean_state_type), pointer :: ocean_state => NULL() type(ice_ocean_boundary_type), pointer :: Ice_ocean_boundary => NULL() type(ocean_internalstate_wrapper) :: ocean_internalstate type(ocean_grid_type), pointer :: ocean_grid character(240) :: msgString + character(240) :: fldname + character(240) :: timestr integer :: fieldCount, n type(ESMF_Field) :: field character(len=64),allocatable :: fieldNameList(:) @@ -1239,10 +1486,21 @@ subroutine DataInitialize(gcomp, rc) ! query the Component for its clock, importState and exportState call ESMF_GridCompGet(gcomp, clock=clock, importState=importState, exportState=exportState, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return ! bail out + + call ESMF_ClockGet(clock, currTime=currTime, timeStep=timeStep, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + call ESMF_TimeGet(currTime, timestring=timestr, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return call ESMF_GridCompGetInternalState(gcomp, ocean_internalstate, rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return ! bail out Ice_ocean_boundary => ocean_internalstate%ptr%ice_ocean_boundary_type_ptr ocean_public => ocean_internalstate%ptr%ocean_public_type_ptr @@ -1250,38 +1508,66 @@ subroutine DataInitialize(gcomp, rc) call get_ocean_grid(ocean_state, ocean_grid) call mom_export(ocean_public, ocean_grid, ocean_state, exportState, clock, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return ! bail out call ESMF_StateGet(exportState, itemCount=fieldCount, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return ! bail out allocate(fieldNameList(fieldCount)) call ESMF_StateGet(exportState, itemNameList=fieldNameList, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return ! bail out do n=1, fieldCount call ESMF_StateGet(exportState, itemName=fieldNameList(n), field=field, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return ! bail out + call NUOPC_SetAttribute(field, name="Updated", value="true", rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return ! bail out enddo deallocate(fieldNameList) ! check whether all Fields in the exportState are "Updated" if (NUOPC_IsUpdated(exportState)) then call NUOPC_CompAttributeSet(gcomp, name="InitializeDataComplete", value="true", rc=rc) - call ESMF_LogWrite("MOM6 - Initialize-Data-Dependency SATISFIED!!!", ESMF_LOGMSG_INFO) - endif - - if(write_diagnostics) then - call NUOPC_Write(exportState, fileNamePrefix='field_init_ocn_export_', & - overwrite=overwrite_timeslice,timeslice=import_slice, relaxedFlag=.true., rc=rc) + call ESMF_LogWrite("MOM6 - Initialize-Data-Dependency SATISFIED!!!", ESMF_LOGMSG_INFO, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & line=__LINE__, & file=__FILE__)) & return ! bail out endif + if(write_diagnostics) then + do n = 1,fldsFrOcn_num + fldname = fldsFrOcn(n)%shortname + call ESMF_StateGet(exportState, itemName=trim(fldname), itemType=itemType, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + + if (itemType /= ESMF_STATEITEM_NOTFOUND) then + call ESMF_StateGet(exportState, itemName=trim(fldname), field=field, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + + call ESMF_FieldWrite(field, fileName='field_init_ocn_export_'//trim(timestr)//'.nc', & + timeslice=1, overwrite=overwrite_timeslice, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + endif + enddo + endif + end subroutine DataInitialize !> Called by NUOPC to advance the model a single timestep. @@ -1297,13 +1583,15 @@ subroutine ModelAdvance(gcomp, rc) logical :: existflag, isPresent, isSet logical :: do_advance = .true. type(ESMF_Clock) :: clock!< ESMF Clock class definition - type(ESMF_Alarm) :: alarm + type(ESMF_Alarm) :: restart_alarm, stop_alarm type(ESMF_State) :: importState, exportState type(ESMF_Time) :: currTime type(ESMF_TimeInterval) :: timeStep type(ESMF_Time) :: startTime type(ESMF_TimeInterval) :: time_elapsed integer(ESMF_KIND_I8) :: n_interval, time_elapsed_sec + type(ESMF_Field) :: lfield + type(ESMF_StateItem_Flag) :: itemType character(len=64) :: timestamp type (ocean_public_type), pointer :: ocean_public => NULL() type (ocean_state_type), pointer :: ocean_state => NULL() @@ -1321,9 +1609,12 @@ subroutine ModelAdvance(gcomp, rc) character(240) :: msgString character(ESMF_MAXSTR) :: casename integer :: iostat - integer :: writeunit + integer :: writeunit integer :: localPet type(ESMF_VM) :: vm + integer :: n + character(240) :: import_timestr, export_timestr + character(len=128) :: fldname character(len=*),parameter :: subname='(MOM_cap:ModelAdvance)' rc = ESMF_SUCCESS @@ -1332,21 +1623,48 @@ subroutine ModelAdvance(gcomp, rc) call shr_file_setLogUnit (logunit) ! query the Component for its clock, importState and exportState - call ESMF_GridCompGet(gcomp, clock=clock, importState=importState, exportState=exportState, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + call ESMF_GridCompGet(gcomp, clock=clock, importState=importState, & + exportState=exportState, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return ! bail out ! HERE THE MODEL ADVANCES: currTime -> currTime + timeStep - call ESMF_ClockPrint(clock, options="currTime", preString="------>Advancing OCN from: ", unit=msgString, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return - call ESMF_LogWrite(subname//trim(msgString), ESMF_LOGMSG_INFO) + call ESMF_ClockPrint(clock, options="currTime", & + preString="------>Advancing OCN from: ", unit=msgString, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return ! bail out + call ESMF_LogWrite(subname//trim(msgString), ESMF_LOGMSG_INFO, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return ! bail out - call ESMF_ClockGet(clock, startTime=startTime, currTime=currTime, timeStep=timeStep, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + call ESMF_ClockGet(clock, startTime=startTime, currTime=currTime, & + timeStep=timeStep, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return ! bail out - call ESMF_TimePrint(currTime + timeStep, preString="--------------------------------> to: ", unit=msgString, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return - call ESMF_LogWrite(trim(msgString), ESMF_LOGMSG_INFO) + call ESMF_TimePrint(currTime + timeStep, & + preString="--------------------------------> to: ", unit=msgString, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return ! bail out + call ESMF_LogWrite(trim(msgString), ESMF_LOGMSG_INFO, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return ! bail out + + call ESMF_TimeGet(currTime, timestring=import_timestr, rc=rc) + call ESMF_TimeGet(currTime+timestep, timestring=export_timestr, rc=rc) Time_step_coupled = esmf2fms_time(timeStep) Time = esmf2fms_time(currTime) @@ -1360,7 +1678,11 @@ subroutine ModelAdvance(gcomp, rc) ! Do not call MOM6 timestepping routine if the first cpl tstep of a startup run if (currTime == startTime) then - call ESMF_LogWrite("MOM6 - Skipping the first coupling timestep", ESMF_LOGMSG_INFO) + call ESMF_LogWrite("MOM6 - Skipping the first coupling timestep", ESMF_LOGMSG_INFO, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return ! bail out do_advance = .false. else do_advance = .true. @@ -1369,9 +1691,18 @@ subroutine ModelAdvance(gcomp, rc) if (do_advance) then ! If the second cpl tstep of a startup run, step back a cpl tstep and advance for two cpl tsteps if (currTime == startTime + timeStep) then - call ESMF_LogWrite("MOM6 - Stepping back one coupling timestep", ESMF_LOGMSG_INFO) + call ESMF_LogWrite("MOM6 - Stepping back one coupling timestep", ESMF_LOGMSG_INFO, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return ! bail out Time = esmf2fms_time(currTime-timeStep) ! i.e., startTime - call ESMF_LogWrite("MOM6 - doubling the coupling timestep", ESMF_LOGMSG_INFO) + + call ESMF_LogWrite("MOM6 - doubling the coupling timestep", ESMF_LOGMSG_INFO, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return ! bail out Time_step_coupled = 2 * esmf2fms_time(timeStep) endif end if @@ -1382,7 +1713,10 @@ subroutine ModelAdvance(gcomp, rc) if (do_advance) then call ESMF_GridCompGetInternalState(gcomp, ocean_internalstate, rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return ! bail out Ice_ocean_boundary => ocean_internalstate%ptr%ice_ocean_boundary_type_ptr ocean_public => ocean_internalstate%ptr%ocean_public_type_ptr @@ -1393,10 +1727,20 @@ subroutine ModelAdvance(gcomp, rc) !--------------- if (write_diagnostics) then - call NUOPC_Write(importState, fileNamePrefix='field_ocn_import_', & - overwrite=overwrite_timeslice,timeslice=import_slice, relaxedFlag=.true., rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return - import_slice = import_slice + 1 + do n = 1,fldsToOcn_num + fldname = fldsToOcn(n)%shortname + call ESMF_StateGet(importState, itemName=trim(fldname), itemType=itemType, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + + if (itemType /= ESMF_STATEITEM_NOTFOUND) then + call ESMF_StateGet(importState, itemName=trim(fldname), field=lfield, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + + call ESMF_FieldWrite(lfield, fileName='field_ocn_import_'//trim(import_timestr)//'.nc', & + timeslice=1, overwrite=overwrite_timeslice, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + endif + enddo endif !--------------- @@ -1410,7 +1754,10 @@ subroutine ModelAdvance(gcomp, rc) !--------------- call mom_import(ocean_public, ocean_grid, importState, ice_ocean_boundary, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return ! bail out !--------------- ! Update MOM6 @@ -1425,29 +1772,58 @@ subroutine ModelAdvance(gcomp, rc) !--------------- call mom_export(ocean_public, ocean_grid, ocean_state, exportState, clock, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return ! bail out endif !--------------- - ! If restart alarm is ringing - write restart file + ! Get the stop alarm !--------------- - call ESMF_ClockGetAlarm(clock, alarmname='alarm_restart', alarm=alarm, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + call ESMF_ClockGetAlarm(clock, alarmname='stop_alarm', alarm=stop_alarm, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return ! bail out - if (ESMF_AlarmIsRinging(alarm, rc=rc)) then - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + !--------------- + ! If restart alarm exists and is ringing - write restart file + !--------------- - call ESMF_AlarmRingerOff(alarm, rc=rc ) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + call ESMF_ClockGetAlarm(clock, alarmname='restart_alarm', alarm=restart_alarm, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return ! bail out - call ESMF_ClockGetNextTime(clock, MyTime, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return - call ESMF_TimeGet (MyTime, yy=year, mm=month, dd=day, h=hour, m=minute, s=seconds, rc=rc ) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + if (ESMF_AlarmIsRinging(restart_alarm, rc=rc)) then + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return ! bail out - if (cesm_coupled) then + ! turn off the alarm + call ESMF_AlarmRingerOff(restart_alarm, rc=rc ) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return ! bail out + + ! determine restart filename + call ESMF_ClockGetNextTime(clock, MyTime, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return ! bail out + call ESMF_TimeGet (MyTime, yy=year, mm=month, dd=day, h=hour, m=minute, s=seconds, rc=rc ) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return ! bail out + if (cesm_coupled) then call NUOPC_CompAttributeGet(gcomp, name='case_name', value=casename, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return call ESMF_GridCompGet(gcomp, vm=vm, rc=rc) @@ -1468,53 +1844,16 @@ subroutine ModelAdvance(gcomp, rc) write(writeunit,'(a)') trim(restartname)//'.nc' close(writeunit) endif - else - write(restartname,'(A,".mom6.r.",I4.4,"-",I2.2,"-",I2.2,"-",I2.2,"-",I2.2,"-",I2.2)') & - "ocn", year, month, day, hour, minute, seconds - endif - call ESMF_LogWrite("MOM_cap: Using restart filename: "//trim(restartname), ESMF_LOGMSG_INFO) - - ! TODO: address if this requirement is being met for the DA group - ! Optionally write restart files when currTime-startTime is integer multiples of restart_interval - ! if (restart_interval > 0 ) then - ! time_elapsed = currTime - startTime - ! call ESMF_TimeIntervalGet(time_elapsed, s_i8=time_elapsed_sec, rc=rc) - ! if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return - ! n_interval = time_elapsed_sec / restart_interval - ! if ((n_interval .gt. 0) .and. (n_interval*restart_interval == time_elapsed_sec)) then - ! time_restart_current = esmf2fms_time(currTime) - ! timestamp = date_to_string(time_restart_current) - ! call ESMF_LogWrite("MOM: Writing restart at "//trim(timestamp), ESMF_LOGMSG_INFO, rc=rc) - ! write(*,*) 'calling ocean_model_restart' - ! call ocean_model_restart(ocean_state, timestamp) - ! endif - ! endif - - ! write restart file(s) - call ocean_model_restart(ocean_state, restartname=restartname) - - if (is_root_pe()) then - write(logunit,*) subname//' writing restart file ',trim(restartname) - endif - - ! TODO: address if this requirement is being met for the DA group - ! Optionally write restart files when currTime-startTime is integer multiples of restart_interval - ! if (restart_interval > 0 ) then - ! time_elapsed = currTime - startTime - ! call ESMF_TimeIntervalGet(time_elapsed, s_i8=time_elapsed_sec, rc=rc) - ! if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - ! line=__LINE__, & - ! file=__FILE__)) & - ! return ! bail out - ! n_interval = time_elapsed_sec / restart_interval - ! if ((n_interval .gt. 0) .and. (n_interval*restart_interval == time_elapsed_sec)) then - ! time_restart_current = esmf2fms_time(currTime) - ! timestamp = date_to_string(time_restart_current) - ! call ESMF_LogWrite("MOM: Writing restart at "//trim(timestamp), ESMF_LOGMSG_INFO, rc=rc) - ! write(*,*) 'calling ocean_model_restart' - ! call ocean_model_restart(ocean_state, timestamp) - ! endif - ! endif + else + ! write the final restart without a timestamp + if (ESMF_AlarmIsRinging(stop_alarm, rc=rc)) then + write(restartname,'(A)')"MOM.res" + else + write(restartname,'(A,I4.4,"-",I2.2,"-",I2.2,"-",I2.2,"-",I2.2,"-",I2.2)') & + "MOM.res.", year, month, day, hour, minute, seconds + endif + end if + call ESMF_LogWrite("MOM_cap: Writing restart : "//trim(restartname), ESMF_LOGMSG_INFO, rc=rc) ! write restart file(s) call ocean_model_restart(ocean_state, restartname=restartname) @@ -1522,17 +1861,27 @@ subroutine ModelAdvance(gcomp, rc) if (is_root_pe()) then write(logunit,*) subname//' writing restart file ',trim(restartname) endif - endif + endif !--------------- ! Write diagnostics !--------------- if (write_diagnostics) then - call NUOPC_Write(exportState, fileNamePrefix='field_ocn_export_', & - overwrite=overwrite_timeslice,timeslice=export_slice, relaxedFlag=.true., rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return - export_slice = export_slice + 1 + do n = 1,fldsFrOcn_num + fldname = fldsFrOcn(n)%shortname + call ESMF_StateGet(exportState, itemName=trim(fldname), itemType=itemType, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + + if (itemType /= ESMF_STATEITEM_NOTFOUND) then + call ESMF_StateGet(exportState, itemName=trim(fldname), field=lfield, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + + call ESMF_FieldWrite(lfield, fileName='field_ocn_export_'//trim(export_timestr)//'.nc', & + timeslice=1, overwrite=overwrite_timeslice, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + endif + enddo endif if(profile_memory) call ESMF_VMLogMemInfo("Leaving MOM Model_ADVANCE: ") @@ -1547,30 +1896,42 @@ subroutine ModelSetRunClock(gcomp, rc) ! local variables type(ESMF_Clock) :: mclock, dclock type(ESMF_Time) :: mcurrtime, dcurrtime - type(ESMF_Time) :: mstoptime + type(ESMF_Time) :: mstoptime, dstoptime type(ESMF_TimeInterval) :: mtimestep, dtimestep character(len=128) :: mtimestring, dtimestring character(len=256) :: cvalue character(len=256) :: restart_option ! Restart option units integer :: restart_n ! Number until restart interval integer :: restart_ymd ! Restart date (YYYYMMDD) - type(ESMF_ALARM) :: restart_alarm + type(ESMF_Alarm) :: restart_alarm + type(ESMF_Alarm) :: stop_alarm logical :: isPresent, isSet logical :: first_time = .true. character(len=*),parameter :: subname='MOM_cap:(ModelSetRunClock) ' + character(len=256) :: timestr !-------------------------------- rc = ESMF_SUCCESS ! query the Component for its clock, importState and exportState call NUOPC_ModelGet(gcomp, driverClock=dclock, modelClock=mclock, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return ! bail out - call ESMF_ClockGet(dclock, currTime=dcurrtime, timeStep=dtimestep, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + call ESMF_ClockGet(dclock, currTime=dcurrtime, timeStep=dtimestep, & + stopTime=dstoptime, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return ! bail out call ESMF_ClockGet(mclock, currTime=mcurrtime, timeStep=mtimestep, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return ! bail out !-------------------------------- ! check that the current time in the model and driver are the same @@ -1578,9 +1939,17 @@ subroutine ModelSetRunClock(gcomp, rc) if (mcurrtime /= dcurrtime) then call ESMF_TimeGet(dcurrtime, timeString=dtimestring, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return ! bail out + call ESMF_TimeGet(mcurrtime, timeString=mtimestring, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return ! bail out + call ESMF_LogSetError(ESMF_RC_VAL_WRONG, & msg=subname//": ERROR in time consistency: "//trim(dtimestring)//" != "//trim(mtimestring), & line=__LINE__, file=__FILE__, rcToReturn=rc) @@ -1594,25 +1963,27 @@ subroutine ModelSetRunClock(gcomp, rc) mstoptime = mcurrtime + dtimestep call ESMF_ClockSet(mclock, currTime=dcurrtime, timeStep=dtimestep, stopTime=mstoptime, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return ! bail out if (first_time) then !-------------------------------- ! set restart alarm !-------------------------------- - ! set ddefaults + ! defaults restart_n = 0 restart_ymd = 0 - call NUOPC_CompAttributeGet(gcomp, name="restart_option", value=restart_option, & - isPresent=isPresent, isSet=isSet, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + if (cesm_coupled) then + call NUOPC_CompAttributeGet(gcomp, name="restart_option", value=restart_option, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return - ! If restart_option is set then must also have set either restart_n or restart_ymd - if (isPresent .and. isSet) then + ! If restart_option is set then must also have set either restart_n or restart_ymd call NUOPC_CompAttributeGet(gcomp, name="restart_n", value=cvalue, & - isPresent=isPresent, isSet=isSet, rc=rc) + isPresent=isPresent, isSet=isSet, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return if (isPresent .and. isSet) then read(cvalue,*) restart_n @@ -1628,26 +1999,83 @@ subroutine ModelSetRunClock(gcomp, rc) msg=subname//": ERROR both restart_n and restart_ymd are zero for restart_option set ", & line=__LINE__, file=__FILE__, rcToReturn=rc) return - end if + endif + call ESMF_LogWrite(subname//" Set restart option = "//restart_option, ESMF_LOGMSG_INFO) + else - restart_option = "none" - endif - call ESMF_LogWrite(subname//" Set restart option = "//restart_option, ESMF_LOGMSG_INFO) + call NUOPC_CompAttributeGet(gcomp, name="restart_n", value=cvalue, & + isPresent=isPresent, isSet=isSet, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, file=__FILE__)) return - ! initialize restart alarm - call AlarmInit(mclock, & - alarm = restart_alarm, & - option = trim(restart_option), & - opt_n = restart_n, & - opt_ymd = restart_ymd, & - RefTime = mcurrTime, & - alarmname = 'alarm_restart', rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + ! If restart_option is set then must also have set either restart_n or restart_ymd + if (isPresent .and. isSet) then + call ESMF_LogWrite(subname//" Restart_n = "//trim(cvalue), ESMF_LOGMSG_INFO, rc=rc) + read(cvalue,*) restart_n + if(restart_n /= 0)then + call NUOPC_CompAttributeGet(gcomp, name="restart_option", value=cvalue, & + isPresent=isPresent, isSet=isSet, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, file=__FILE__)) return + if (isPresent .and. isSet) then + read(cvalue,*) restart_option + call ESMF_LogWrite(subname//" Restart_option = "//restart_option, & + ESMF_LOGMSG_INFO, rc=rc) + endif + + call NUOPC_CompAttributeGet(gcomp, name="restart_ymd", value=cvalue, & + isPresent=isPresent, isSet=isSet, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, file=__FILE__)) return + if (isPresent .and. isSet) then + read(cvalue,*) restart_ymd + call ESMF_LogWrite(subname//" Restart_ymd = "//trim(cvalue), ESMF_LOGMSG_INFO, rc=rc) + endif + else + restart_option = 'none' + call ESMF_LogWrite(subname//" Set restart option = "//restart_option, & + ESMF_LOGMSG_INFO, rc=rc) + !TODO: Find a better way + !Create but disable the restart_alarm; this is so restart writing can function w or w/o + !restart_n=0 + restart_alarm = ESMF_AlarmCreate(mclock, ringtime=dstopTime, name = "restart_alarm", enabled = .false., rc=rc) + call ESMF_LogWrite(subname//" Restart alarm is Created but Disabled", ESMF_LOGMSG_INFO, rc=rc) + endif + endif + endif - call ESMF_AlarmSet(restart_alarm, clock=mclock, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + ! Do not initialize an alarm if the restart option is none + if (restart_option /= 'none') then + call AlarmInit(mclock, & + alarm = restart_alarm, & + option = trim(restart_option), & + opt_n = restart_n, & + opt_ymd = restart_ymd, & + RefTime = mcurrTime, & + alarmname = 'restart_alarm', rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return ! bail out + + call ESMF_AlarmSet(restart_alarm, clock=mclock, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return ! bail out + call ESMF_LogWrite(subname//" Restart alarm is Created and Set", ESMF_LOGMSG_INFO, rc=rc) + end if first_time = .false. + + ! create a 1-shot alarm at the driver stop time + stop_alarm = ESMF_AlarmCreate(mclock, ringtime=dstopTime, name = "stop_alarm", rc=rc) + call ESMF_LogWrite(subname//" Create Stop alarm", ESMF_LOGMSG_INFO, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, file=__FILE__)) return + + call ESMF_TimeGet(dstoptime, timestring=timestr, rc=rc) + call ESMF_LogWrite("Stop Alarm will ring at : "//trim(timestr), ESMF_LOGMSG_INFO, rc=rc) endif !-------------------------------- @@ -1655,10 +2083,16 @@ subroutine ModelSetRunClock(gcomp, rc) !-------------------------------- call ESMF_ClockAdvance(mclock,rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return ! bail out call ESMF_ClockSet(mclock, currTime=dcurrtime, timeStep=dtimestep, stopTime=mstoptime, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return ! bail out end subroutine ModelSetRunClock @@ -1681,7 +2115,12 @@ subroutine ocean_model_finalize(gcomp, rc) type(TIME_TYPE) :: Time type(ESMF_Clock) :: clock type(ESMF_Time) :: currTime + type(ESMF_Alarm), allocatable :: alarmList(:) + integer :: alarmCount character(len=64) :: timestamp + character(len=64) :: alarm_name + logical :: write_restart + integer :: i character(len=*),parameter :: subname='(MOM_cap:ocean_model_finalize)' write(*,*) 'MOM: --- finalize called ---' @@ -1709,11 +2148,25 @@ subroutine ocean_model_finalize(gcomp, rc) return ! bail out Time = esmf2fms_time(currTime) - if (cesm_coupled) then - call ocean_model_end(ocean_public, ocean_State, Time, write_restart=.false.) - else - call ocean_model_end(ocean_public, ocean_State, Time, write_restart=.true.) - endif + ! Check if the clock has a restart alarm - and if it does do not write a restart + call ESMF_ClockGet(clock, alarmCount=alarmCount, rc = rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, file=__FILE__)) return + + allocate(alarmList(1:alarmCount)) + call ESMF_ClockGetAlarmList(clock, alarmlistflag=ESMF_ALARMLIST_ALL, alarmList=alarmList, rc = rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, file=__FILE__)) return + + write_restart = .true. + do i = 1,alarmCount + call ESMF_AlarmGet(alarmlist(i), name=alarm_name, rc = rc) + if(trim(alarm_name) == 'restart_alarm' .and. ESMF_AlarmIsEnabled(alarmlist(i), rc=rc))write_restart = .false. + enddo + deallocate(alarmList) + + if(write_restart)call ESMF_LogWrite("No Restart Alarm, writing restart at Finalize ", ESMF_LOGMSG_INFO, rc=rc) + call ocean_model_end(ocean_public, ocean_State, Time, write_restart=write_restart) call field_manager_end() call fms_io_exit() @@ -1789,37 +2242,58 @@ subroutine MOM_RealizeFields(state, nfields, field_defs, tag, grid, mesh, rc) if (field_defs(i)%shortname == scalar_field_name) then - call ESMF_LogWrite(subname//tag//" Field "//trim(field_defs(i)%stdname)//" is connected on root pe.", & - ESMF_LOGMSG_INFO) + call ESMF_LogWrite(subname // tag // " Field "// trim(field_defs(i)%stdname) // " is connected on root pe.", & + ESMF_LOGMSG_INFO, & + line=__LINE__, & + file=__FILE__, & + rc=rc) call SetScalarField(field, rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return ! bail out else call ESMF_LogWrite(subname // tag // " Field "// trim(field_defs(i)%stdname) // " is connected.", & - ESMF_LOGMSG_INFO) + ESMF_LOGMSG_INFO, & + line=__LINE__, & + file=__FILE__, & + rc=rc) if (present(grid)) then field = ESMF_FieldCreate(grid, ESMF_TYPEKIND_R8, indexflag=ESMF_INDEX_DELOCAL, & name=field_defs(i)%shortname, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return ! bail out ! initialize fldptr to zero call ESMF_FieldGet(field, farrayPtr=fldptr2d, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return ! bail out fldptr2d(:,:) = 0.0 else if (present(mesh)) then field = ESMF_FieldCreate(mesh=mesh, typekind=ESMF_TYPEKIND_R8, meshloc=ESMF_MESHLOC_ELEMENT, & name=field_defs(i)%shortname, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return ! bail out ! initialize fldptr to zero call ESMF_FieldGet(field, farrayPtr=fldptr1d, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return ! bail out fldptr1d(:) = 0.0 endif @@ -1828,16 +2302,24 @@ subroutine MOM_RealizeFields(state, nfields, field_defs, tag, grid, mesh, rc) ! Realize connected field call NUOPC_Realize(state, field=field, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return ! bail out else ! field is not connected call ESMF_LogWrite(subname // tag // " Field "// trim(field_defs(i)%stdname) // " is not connected.", & - ESMF_LOGMSG_INFO) - + ESMF_LOGMSG_INFO, & + line=__LINE__, & + file=__FILE__, & + rc=rc) ! remove a not connected Field from State call ESMF_StateRemove(state, (/field_defs(i)%shortname/), rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return ! bail out endif From f9b63f304e71b7f8beeb4364df9f51f462310e58 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Tue, 7 Apr 2020 12:39:21 -0400 Subject: [PATCH 153/316] +Added RL2_T2_to_Pa element to unit_scale_type Added new RL2_T2_to_Pa and W_m2_to_RZ3_T3 elements to the unit_scale_type for code simplification and clarity. Also corrected spelling errors in the get_param descriptions of 5 scaling factors, which will change comments in the MOM_parameter_doc.debugging files. All answers are bitwise identical. --- src/framework/MOM_unit_scaling.F90 | 49 +++++++++++++++++++----------- 1 file changed, 32 insertions(+), 17 deletions(-) diff --git a/src/framework/MOM_unit_scaling.F90 b/src/framework/MOM_unit_scaling.F90 index 30e9c49850..7ef0486c0e 100644 --- a/src/framework/MOM_unit_scaling.F90 +++ b/src/framework/MOM_unit_scaling.F90 @@ -24,20 +24,23 @@ module MOM_unit_scaling real :: J_kg_to_Q !< A constant that translates Joules per kilogram to the units of enthalpy. ! These are useful combinations of the fundamental scale conversion factors above. - real :: Z_to_L !< Convert vertical distances to lateral lengths - real :: L_to_Z !< Convert vertical distances to lateral lengths - real :: L_T_to_m_s !< Convert lateral velocities from L T-1 to m s-1. - real :: m_s_to_L_T !< Convert lateral velocities from m s-1 to L T-1. - real :: L_T2_to_m_s2 !< Convert lateral accelerations from L T-2 to m s-2. - real :: Z2_T_to_m2_s !< Convert vertical diffusivities from Z2 T-1 to m2 s-1. - real :: m2_s_to_Z2_T !< Convert vertical diffusivities from m2 s-1 to Z2 T-1. - real :: W_m2_to_QRZ_T !< Convert heat fluxes from W m-2 to Q R Z T-1. - real :: QRZ_T_to_W_m2 !< Convert heat fluxes from Q R Z T-1 to W m-2. + real :: Z_to_L !< Convert vertical distances to lateral lengths + real :: L_to_Z !< Convert lateral lengths to vertical distances + real :: L_T_to_m_s !< Convert lateral velocities from L T-1 to m s-1. + real :: m_s_to_L_T !< Convert lateral velocities from m s-1 to L T-1. + real :: L_T2_to_m_s2 !< Convert lateral accelerations from L T-2 to m s-2. + real :: Z2_T_to_m2_s !< Convert vertical diffusivities from Z2 T-1 to m2 s-1. + real :: m2_s_to_Z2_T !< Convert vertical diffusivities from m2 s-1 to Z2 T-1. + real :: W_m2_to_QRZ_T !< Convert heat fluxes from W m-2 to Q R Z T-1. + real :: QRZ_T_to_W_m2 !< Convert heat fluxes from Q R Z T-1 to W m-2. ! Not used enough: real :: kg_m2_to_RZ !< Convert mass loads from kg m-2 to R Z. - real :: RZ_to_kg_m2 !< Convert mass loads from R Z to kg m-2. + real :: RZ_to_kg_m2 !< Convert mass loads from R Z to kg m-2. real :: kg_m2s_to_RZ_T !< Convert mass fluxes from kg m-2 s-1 to R Z T-1. real :: RZ_T_to_kg_m2s !< Convert mass fluxes from R Z T-1 to kg m-2 s-1. real :: RZ3_T3_to_W_m2 !< Convert turbulent kinetic energy fluxes from R Z3 T-3 to W m-2. + real :: W_m2_to_RZ3_T3 !< Convert turbulent kinetic energy fluxes from W m-2 to R Z3 T-3. + real :: RL2_T2_to_Pa !< Convert pressures from R L2 T-2 to Pa. + ! Not used enough: real :: Pa_to_RL2_T2 !< Convert pressures from Pa to R L2 T-2. ! These are used for changing scaling across restarts. real :: m_to_Z_restart = 0.0 !< A copy of the m_to_Z that is used in restart files. @@ -72,23 +75,23 @@ subroutine unit_scaling_init( param_file, US ) "Parameters for doing unit scaling of variables.") call get_param(param_file, mdl, "Z_RESCALE_POWER", Z_power, & "An integer power of 2 that is used to rescale the model's "//& - "intenal units of depths and heights. Valid values range from -300 to 300.", & + "internal units of depths and heights. Valid values range from -300 to 300.", & units="nondim", default=0, debuggingParam=.true.) call get_param(param_file, mdl, "L_RESCALE_POWER", L_power, & "An integer power of 2 that is used to rescale the model's "//& - "intenal units of lateral distances. Valid values range from -300 to 300.", & + "internal units of lateral distances. Valid values range from -300 to 300.", & units="nondim", default=0, debuggingParam=.true.) call get_param(param_file, mdl, "T_RESCALE_POWER", T_power, & "An integer power of 2 that is used to rescale the model's "//& - "intenal units of time. Valid values range from -300 to 300.", & + "internal units of time. Valid values range from -300 to 300.", & units="nondim", default=0, debuggingParam=.true.) call get_param(param_file, mdl, "R_RESCALE_POWER", R_power, & "An integer power of 2 that is used to rescale the model's "//& - "intenal units of density. Valid values range from -300 to 300.", & + "internal units of density. Valid values range from -300 to 300.", & units="nondim", default=0, debuggingParam=.true.) call get_param(param_file, mdl, "Q_RESCALE_POWER", Q_power, & "An integer power of 2 that is used to rescale the model's "//& - "intenal units of heat content. Valid values range from -300 to 300.", & + "internal units of heat content. Valid values range from -300 to 300.", & units="nondim", default=0, debuggingParam=.true.) if (abs(Z_power) > 300) call MOM_error(FATAL, "unit_scaling_init: "//& "Z_RESCALE_POWER is outside of the valid range of -300 to 300.") @@ -129,19 +132,31 @@ subroutine unit_scaling_init( param_file, US ) ! These are useful combinations of the fundamental scale conversion factors set above. US%Z_to_L = US%Z_to_m * US%m_to_L US%L_to_Z = US%L_to_m * US%m_to_Z + ! Horizontal velocities: US%L_T_to_m_s = US%L_to_m * US%s_to_T US%m_s_to_L_T = US%m_to_L * US%T_to_s + ! Horizontal accelerations: US%L_T2_to_m_s2 = US%L_to_m * US%s_to_T**2 - ! It does not look like US%m_s2_to_L_T2 would be used, so it does not exist. + ! It does not look like US%m_s2_to_L_T2 would be used, so it does not exist. + ! Vertical diffusivities and viscosities: US%Z2_T_to_m2_s = US%Z_to_m**2 * US%s_to_T US%m2_s_to_Z2_T = US%m_to_Z**2 * US%T_to_s - ! It does not seem like US%kg_m2_to_RZ would be used enough in MOM6 to justify its existence. + ! Column mass loads: US%RZ_to_kg_m2 = US%R_to_kg_m3 * US%Z_to_m + ! It does not seem like US%kg_m2_to_RZ would be used enough in MOM6 to justify its existence. + ! Vertical mass fluxes: US%kg_m2s_to_RZ_T = US%kg_m3_to_R * US%m_to_Z * US%T_to_s US%RZ_T_to_kg_m2s = US%R_to_kg_m3 * US%Z_to_m * US%s_to_T + ! Turbulent kinetic energy vertical fluxes: US%RZ3_T3_to_W_m2 = US%R_to_kg_m3 * US%Z_to_m**3 * US%s_to_T**3 + US%W_m2_to_RZ3_T3 = US%kg_m3_to_R * US%m_to_Z**3 * US%T_to_s**3 + ! Vertical heat fluxes: US%W_m2_to_QRZ_T = US%J_kg_to_Q * US%kg_m3_to_R * US%m_to_Z * US%T_to_s US%QRZ_T_to_W_m2 = US%Q_to_J_kg * US%R_to_kg_m3 * US%Z_to_m * US%s_to_T + ! Pressures: + US%RL2_T2_to_Pa = US%R_to_kg_m3 * US%L_T_to_m_s**2 + ! It does not seem like US%Pa_to_RL2_T2 would be used enough in MOM6 to justify its existence. + ! US%Pa_to_RL2_T2 = US%kg_m3_to_R * US%m_s_to_L_T**2 end subroutine unit_scaling_init From 6d7dde4805df7a830d8bc1ffa5486f5102119ac8 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Tue, 7 Apr 2020 12:44:48 -0400 Subject: [PATCH 154/316] Use combined scaling factors Replaced products of scaling factors (like US%R_to_kg_m3*US%L_T_to_m_s**2) with combined scaling factors (like US%RL2_T2_to_Pa) to simplfy and clarify the code. All answers are bitwise idenical. --- src/core/MOM.F90 | 4 ++-- src/core/MOM_PressureForce_Montgomery.F90 | 12 ++++++------ src/core/MOM_PressureForce_analytic_FV.F90 | 12 ++++++------ src/core/MOM_PressureForce_blocked_AFV.F90 | 10 +++++----- src/core/MOM_forcing_type.F90 | 12 ++++++------ src/core/MOM_interface_heights.F90 | 4 ++-- src/core/MOM_isopycnal_slopes.F90 | 4 ++-- src/diagnostics/MOM_diagnostics.F90 | 4 ++-- .../lateral/MOM_mixed_layer_restrat.F90 | 2 +- .../vertical/MOM_internal_tide_input.F90 | 4 ++-- .../vertical/MOM_set_diffusivity.F90 | 11 +++++------ src/parameterizations/vertical/MOM_tidal_mixing.F90 | 4 ++-- src/user/SCM_CVMix_tests.F90 | 4 ++-- 13 files changed, 43 insertions(+), 44 deletions(-) diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index 213f81a06e..def4fd5197 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -2987,13 +2987,13 @@ subroutine extract_surface_state(CS, sfc_state) if (allocated(sfc_state%taux_shelf) .and. associated(CS%visc%taux_shelf)) then !$OMP parallel do default(shared) do j=js,je ; do I=is-1,ie - sfc_state%taux_shelf(I,j) = US%R_to_kg_m3*US%L_T_to_m_s**2*US%Z_to_L*CS%visc%taux_shelf(I,j) + sfc_state%taux_shelf(I,j) = US%RZ_T_to_kg_m2s*US%L_T_to_m_s*CS%visc%taux_shelf(I,j) enddo ; enddo endif if (allocated(sfc_state%tauy_shelf) .and. associated(CS%visc%tauy_shelf)) then !$OMP parallel do default(shared) do J=js-1,je ; do i=is,ie - sfc_state%tauy_shelf(i,J) = US%R_to_kg_m3*US%L_T_to_m_s**2*US%Z_to_L*CS%visc%tauy_shelf(i,J) + sfc_state%tauy_shelf(i,J) = US%RZ_T_to_kg_m2s*US%L_T_to_m_s*CS%visc%tauy_shelf(i,J) enddo ; enddo endif diff --git a/src/core/MOM_PressureForce_Montgomery.F90 b/src/core/MOM_PressureForce_Montgomery.F90 index 2aa13c5f39..b8dbfbc6fd 100644 --- a/src/core/MOM_PressureForce_Montgomery.F90 +++ b/src/core/MOM_PressureForce_Montgomery.F90 @@ -187,7 +187,7 @@ subroutine PressureForce_Mont_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, pb do k=1,nz call int_specific_vol_dp(tv%T(:,:,k), tv%S(:,:,k), p(:,:,k), p(:,:,k+1), & 0.0, G%HI, tv%eqn_of_state, dz_geo(:,:,k), halo_size=1, & - SV_scale=US%R_to_kg_m3, pres_scale=US%R_to_kg_m3*US%L_T_to_m_s**2) + SV_scale=US%R_to_kg_m3, pres_scale=US%RL2_T2_to_Pa) enddo !$OMP parallel do default(shared) do j=Jsq,Jeq+1 ; do k=1,nz ; do i=Isq,Ieq+1 @@ -660,7 +660,7 @@ subroutine Set_pbce_Bouss(e, tv, G, GV, US, Rho0, GFS_scale, pbce, rho_star) press(i) = -Rho0xG*e(i,j,1) enddo call calculate_density(tv%T(:,j,1), tv%S(:,j,1), press, rho_in_situ, Isq, Ieq-Isq+2, & - tv%eqn_of_state, scale=US%kg_m3_to_R, pres_scale=US%R_to_kg_m3*US%L_T_to_m_s**2) + tv%eqn_of_state, scale=US%kg_m3_to_R, pres_scale=US%RL2_T2_to_Pa) do i=Isq,Ieq+1 pbce(i,j,1) = G_Rho0*(GFS_scale * rho_in_situ(i)) * GV%H_to_Z enddo @@ -671,7 +671,7 @@ subroutine Set_pbce_Bouss(e, tv, G, GV, US, Rho0, GFS_scale, pbce, rho_star) S_int(i) = 0.5*(tv%S(i,j,k-1)+tv%S(i,j,k)) enddo call calculate_density_derivs(T_int, S_int, press, dR_dT, dR_dS, Isq, Ieq-Isq+2, & - tv%eqn_of_state, scale=US%kg_m3_to_R, pres_scale=US%R_to_kg_m3*US%L_T_to_m_s**2) + tv%eqn_of_state, scale=US%kg_m3_to_R, pres_scale=US%RL2_T2_to_Pa) do i=Isq,Ieq+1 pbce(i,j,k) = pbce(i,j,k-1) + G_Rho0 * & ((e(i,j,K) - e(i,j,nz+1)) * Ihtot(i)) * & @@ -757,7 +757,7 @@ subroutine Set_pbce_nonBouss(p, tv, G, GV, US, GFS_scale, pbce, alpha_star) do j=Jsq,Jeq+1 call calculate_density(tv%T(:,j,nz), tv%S(:,j,nz), p(:,j,nz+1), rho_in_situ, & Isq, Ieq-Isq+2, tv%eqn_of_state, scale=US%kg_m3_to_R, & - pres_scale=US%R_to_kg_m3*US%L_T_to_m_s**2) + pres_scale=US%RL2_T2_to_Pa) do i=Isq,Ieq+1 C_htot(i,j) = dP_dH / ((p(i,j,nz+1)-p(i,j,1)) + dp_neglect) pbce(i,j,nz) = dP_dH / (rho_in_situ(i)) @@ -768,10 +768,10 @@ subroutine Set_pbce_nonBouss(p, tv, G, GV, US, GFS_scale, pbce, alpha_star) S_int(i) = 0.5*(tv%S(i,j,k)+tv%S(i,j,k+1)) enddo call calculate_density(T_int, S_int, p(:,j,k+1), rho_in_situ, Isq, Ieq-Isq+2, tv%eqn_of_state, & - scale=US%kg_m3_to_R, pres_scale=US%R_to_kg_m3*US%L_T_to_m_s**2) + scale=US%kg_m3_to_R, pres_scale=US%RL2_T2_to_Pa) call calculate_density_derivs(T_int, S_int, p(:,j,k+1), dR_dT, dR_dS, & Isq, Ieq-Isq+2, tv%eqn_of_state, & - scale=US%kg_m3_to_R, pres_scale=US%R_to_kg_m3*US%L_T_to_m_s**2) + scale=US%kg_m3_to_R, pres_scale=US%RL2_T2_to_Pa) do i=Isq,Ieq+1 pbce(i,j,k) = pbce(i,j,k+1) + ((p(i,j,K+1)-p(i,j,1))*C_htot(i,j)) * & ((dR_dT(i)*(tv%T(i,j,k+1)-tv%T(i,j,k)) + & diff --git a/src/core/MOM_PressureForce_analytic_FV.F90 b/src/core/MOM_PressureForce_analytic_FV.F90 index aca19a6ec6..6d0465f047 100644 --- a/src/core/MOM_PressureForce_analytic_FV.F90 +++ b/src/core/MOM_PressureForce_analytic_FV.F90 @@ -266,7 +266,7 @@ subroutine PressureForce_AFV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p 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, & - SV_scale=US%R_to_kg_m3, pres_scale=US%R_to_kg_m3*US%L_T_to_m_s**2) + SV_scale=US%R_to_kg_m3, pres_scale=US%RL2_T2_to_Pa) elseif ( CS%Recon_Scheme == 2 ) then call MOM_error(FATAL, "PressureForce_AFV_nonBouss: "//& "int_spec_vol_dp_generic_ppm does not exist yet.") @@ -281,7 +281,7 @@ subroutine PressureForce_AFV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p dza(:,:,k), intp_dza(:,:,k), intx_dza(:,:,k), & inty_dza(:,:,k), bathyP=p(:,:,nz+1), dP_tiny=dp_neglect, & useMassWghtInterp=CS%useMassWghtInterp, & - SV_scale=US%R_to_kg_m3, pres_scale=US%R_to_kg_m3*US%L_T_to_m_s**2) + SV_scale=US%R_to_kg_m3, pres_scale=US%RL2_T2_to_Pa) endif else alpha_anom = 1.0 / GV%Rlay(k) - alpha_ref @@ -336,7 +336,7 @@ subroutine PressureForce_AFV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p !$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, scale=US%kg_m3_to_R, pres_scale=US%R_to_kg_m3*US%L_T_to_m_s**2) + tv%eqn_of_state, scale=US%kg_m3_to_R, pres_scale=US%RL2_T2_to_Pa) 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)) @@ -670,18 +670,18 @@ subroutine PressureForce_AFV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_at 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, & - rho_scale=US%kg_m3_to_R, pres_scale=US%R_to_kg_m3*US%L_T_to_m_s**2) + rho_scale=US%kg_m3_to_R, pres_scale=US%RL2_T2_to_Pa) 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, & - rho_scale=US%kg_m3_to_R, pres_scale=US%R_to_kg_m3*US%L_T_to_m_s**2) + rho_scale=US%kg_m3_to_R, pres_scale=US%RL2_T2_to_Pa) 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%HI, tv%eqn_of_state, & dpa, intz_dpa, intx_dpa, inty_dpa, G%bathyT, dz_neglect, CS%useMassWghtInterp, & - rho_scale=US%kg_m3_to_R, pres_scale=US%R_to_kg_m3*US%L_T_to_m_s**2) + rho_scale=US%kg_m3_to_R, pres_scale=US%RL2_T2_to_Pa) endif !$OMP parallel do default(shared) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 diff --git a/src/core/MOM_PressureForce_blocked_AFV.F90 b/src/core/MOM_PressureForce_blocked_AFV.F90 index 34b3b8301d..08951d9eb0 100644 --- a/src/core/MOM_PressureForce_blocked_AFV.F90 +++ b/src/core/MOM_PressureForce_blocked_AFV.F90 @@ -249,7 +249,7 @@ subroutine PressureForce_blk_AFV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, dza(:,:,k), intp_dza(:,:,k), intx_dza(:,:,k), & inty_dza(:,:,k), bathyP=p(:,:,nz+1), dP_tiny=dp_neglect, & useMassWghtInterp=CS%useMassWghtInterp, & - SV_scale=US%R_to_kg_m3, pres_scale=US%R_to_kg_m3*US%L_T_to_m_s**2) + SV_scale=US%R_to_kg_m3, pres_scale=US%RL2_T2_to_Pa) else alpha_anom = 1.0 / GV%Rlay(k) - alpha_ref do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 @@ -303,7 +303,7 @@ subroutine PressureForce_blk_AFV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, !$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, scale=US%kg_m3_to_R, pres_scale=US%R_to_kg_m3*US%L_T_to_m_s**2) + tv%eqn_of_state, scale=US%kg_m3_to_R, pres_scale=US%RL2_T2_to_Pa) 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)) @@ -670,20 +670,20 @@ subroutine PressureForce_blk_AFV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, 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, & - rho_scale=US%kg_m3_to_R, pres_scale=US%R_to_kg_m3*US%L_T_to_m_s**2) + rho_scale=US%kg_m3_to_R, pres_scale=US%RL2_T2_to_Pa) 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, & - rho_scale=US%kg_m3_to_R, pres_scale=US%R_to_kg_m3*US%L_T_to_m_s**2) + rho_scale=US%kg_m3_to_R, pres_scale=US%RL2_T2_to_Pa) 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, & - rho_scale=US%kg_m3_to_R, pres_scale=US%R_to_kg_m3*US%L_T_to_m_s**2) + rho_scale=US%kg_m3_to_R, pres_scale=US%RL2_T2_to_Pa) 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%Z_to_H diff --git a/src/core/MOM_forcing_type.F90 b/src/core/MOM_forcing_type.F90 index 167ae0581d..b1b29ee9d3 100644 --- a/src/core/MOM_forcing_type.F90 +++ b/src/core/MOM_forcing_type.F90 @@ -1116,7 +1116,7 @@ subroutine MOM_mech_forcing_chksum(mesg, forces, G, US, haloshift) ! and js...je as their extent. if (associated(forces%taux) .and. associated(forces%tauy)) & call uvchksum(mesg//" forces%tau[xy]", forces%taux, forces%tauy, G%HI, & - haloshift=hshift, symmetric=.true., scale=US%R_to_kg_m3*US%L_T_to_m_s**2*US%Z_to_L) + haloshift=hshift, symmetric=.true., scale=US%RZ_T_to_kg_m2s*US%L_T_to_m_s) if (associated(forces%p_surf)) & call hchksum(forces%p_surf, mesg//" forces%p_surf",G%HI,haloshift=hshift) if (associated(forces%ustar)) & @@ -1230,17 +1230,17 @@ subroutine register_forcing_type_diags(Time, diag, US, use_temperature, handles, handles%id_taux = register_diag_field('ocean_model', 'taux', diag%axesCu1, Time, & 'Zonal surface stress from ocean interactions with atmos and ice', & - 'Pa', conversion=US%R_to_kg_m3*US%L_T_to_m_s**2*US%Z_to_L, & + 'Pa', conversion=US%RZ_T_to_kg_m2s*US%L_T_to_m_s, & standard_name='surface_downward_x_stress', cmor_field_name='tauuo', & cmor_units='N m-2', cmor_long_name='Surface Downward X Stress', & cmor_standard_name='surface_downward_x_stress') handles%id_tauy = register_diag_field('ocean_model', 'tauy', diag%axesCv1, Time, & 'Meridional surface stress ocean interactions with atmos and ice', & - 'Pa', conversion=US%R_to_kg_m3*US%L_T_to_m_s**2*US%Z_to_L, & - standard_name='surface_downward_y_stress', cmor_field_name='tauvo', & - cmor_units='N m-2', cmor_long_name='Surface Downward Y Stress', & - cmor_standard_name='surface_downward_y_stress') + 'Pa', conversion=US%RZ_T_to_kg_m2s*US%L_T_to_m_s, & + standard_name='surface_downward_y_stress', cmor_field_name='tauvo', & + cmor_units='N m-2', cmor_long_name='Surface Downward Y Stress', & + cmor_standard_name='surface_downward_y_stress') handles%id_ustar = register_diag_field('ocean_model', 'ustar', diag%axesT1, Time, & 'Surface friction velocity = [(gustiness + tau_magnitude)/rho0]^(1/2)', & diff --git a/src/core/MOM_interface_heights.F90 b/src/core/MOM_interface_heights.F90 index 06868b875f..c7147669dd 100644 --- a/src/core/MOM_interface_heights.F90 +++ b/src/core/MOM_interface_heights.F90 @@ -107,7 +107,7 @@ subroutine find_eta_3d(h, tv, G, GV, US, eta, eta_bt, halo_size, eta_to_m) do k=1,nz call int_specific_vol_dp(tv%T(:,:,k), tv%S(:,:,k), p(:,:,K), p(:,:,K+1), & 0.0, G%HI, tv%eqn_of_state, dz_geo(:,:,k), halo_size=halo, & - SV_scale=US%R_to_kg_m3, pres_scale=US%R_to_kg_m3*US%L_T_to_m_s**2) + SV_scale=US%R_to_kg_m3, pres_scale=US%RL2_T2_to_Pa) enddo !$OMP do do j=jsv,jev @@ -210,7 +210,7 @@ subroutine find_eta_2d(h, tv, G, GV, US, eta, eta_bt, halo_size, eta_to_m) do k = 1, nz call int_specific_vol_dp(tv%T(:,:,k), tv%S(:,:,k), p(:,:,k), p(:,:,k+1), 0.0, & G%HI, tv%eqn_of_state, dz_geo(:,:,k), halo_size=halo, & - SV_scale=US%R_to_kg_m3, pres_scale=US%R_to_kg_m3*US%L_T_to_m_s**2) + SV_scale=US%R_to_kg_m3, pres_scale=US%RL2_T2_to_Pa) enddo !$OMP do do j=js,je ; do k=1,nz ; do i=is,ie diff --git a/src/core/MOM_isopycnal_slopes.F90 b/src/core/MOM_isopycnal_slopes.F90 index 11ae7baa26..e5101d9937 100644 --- a/src/core/MOM_isopycnal_slopes.F90 +++ b/src/core/MOM_isopycnal_slopes.F90 @@ -177,7 +177,7 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, & enddo call calculate_density_derivs(T_u, S_u, pres_u, drho_dT_u, & drho_dS_u, (is-IsdB+1)-1, ie-is+2, tv%eqn_of_state, scale=US%kg_m3_to_R, & - pres_scale=US%R_to_kg_m3*US%L_T_to_m_s**2) + pres_scale=US%RL2_T2_to_Pa) endif do I=is-1,ie @@ -264,7 +264,7 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, & enddo call calculate_density_derivs(T_v, S_v, pres_v, drho_dT_v, & drho_dS_v, is, ie-is+1, tv%eqn_of_state, scale=US%kg_m3_to_R, & - pres_scale=US%R_to_kg_m3*US%L_T_to_m_s**2) + pres_scale=US%RL2_T2_to_Pa) endif do i=is,ie if (use_EOS) then diff --git a/src/diagnostics/MOM_diagnostics.F90 b/src/diagnostics/MOM_diagnostics.F90 index 63e664a0ed..0af64c98ff 100644 --- a/src/diagnostics/MOM_diagnostics.F90 +++ b/src/diagnostics/MOM_diagnostics.F90 @@ -843,7 +843,7 @@ subroutine calculate_vertical_integrals(h, tv, p_surf, G, GV, US, CS) enddo ; enddo call int_density_dz(tv%T(:,:,k), tv%S(:,:,k), z_top, z_bot, 0.0, GV%Rho0, GV%g_Earth, & G%HI, G%HI, tv%eqn_of_state, dpress, rho_scale=US%kg_m3_to_R, & - pres_scale=US%R_to_kg_m3*US%L_T_to_m_s**2) + pres_scale=US%RL2_T2_to_Pa) do j=js,je ; do i=is,ie mass(i,j) = mass(i,j) + dpress(i,j) * IG_Earth enddo ; enddo @@ -1732,7 +1732,7 @@ subroutine MOM_diagnostics_init(MIS, ADp, CDp, Time, G, GV, US, param_file, diag 'The height of the water column', 'm', conversion=US%Z_to_m) CS%id_pbo = register_diag_field('ocean_model', 'pbo', diag%axesT1, Time, & long_name='Sea Water Pressure at Sea Floor', standard_name='sea_water_pressure_at_sea_floor', & - units='Pa', conversion=US%R_to_kg_m3*US%L_T_to_m_s**2) + units='Pa', conversion=US%RL2_T2_to_Pa) call set_dependent_diagnostics(MIS, ADp, CDp, G, CS) diff --git a/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 b/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 index 3ef9bd308a..c535cc9334 100644 --- a/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 +++ b/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 @@ -353,7 +353,7 @@ subroutine mixedlayer_restrat_general(h, uhtr, vhtr, tv, forces, dt, MLD_in, Var call hchksum(forces%ustar,'mixed_layer_restrat: u*', G%HI, haloshift=1, scale=US%Z_to_m*US%s_to_T) call hchksum(MLD_fast,'mixed_layer_restrat: MLD', G%HI, haloshift=1, scale=GV%H_to_m) call hchksum(Rml_av_fast,'mixed_layer_restrat: rml', G%HI, haloshift=1, & - scale=US%m_to_Z*US%L_to_m**2*US%s_to_T**2) + scale=US%m_to_Z*US%L_T_to_m_s**2) endif ! TO DO: diff --git a/src/parameterizations/vertical/MOM_internal_tide_input.F90 b/src/parameterizations/vertical/MOM_internal_tide_input.F90 index ebd5016855..e37f7a397d 100644 --- a/src/parameterizations/vertical/MOM_internal_tide_input.F90 +++ b/src/parameterizations/vertical/MOM_internal_tide_input.F90 @@ -137,7 +137,7 @@ subroutine set_int_tide_input(u, v, h, tv, fluxes, itide, dt, G, GV, US, CS) if (CS%debug) then call hchksum(N2_bot,"N2_bot",G%HI,haloshift=0, scale=US%s_to_T**2) call hchksum(itide%TKE_itidal_input,"TKE_itidal_input",G%HI,haloshift=0, & - scale=US%R_to_kg_m3*US%Z_to_m**3*US%s_to_T**3) + scale=US%RZ3_T3_to_W_m2) endif if (CS%id_TKE_itidal > 0) call post_data(CS%id_TKE_itidal, itide%TKE_itidal_input, CS%diag) @@ -349,7 +349,7 @@ subroutine int_tide_input_init(Time, G, GV, US, param_file, diag, CS, itide) call get_param(param_file, mdl, "TKE_ITIDE_MAX", CS%TKE_itide_max, & "The maximum internal tide energy source available to mix "//& "above the bottom boundary layer with INT_TIDE_DISSIPATION.", & - units="W m-2", default=1.0e3, scale=US%kg_m3_to_R*US%m_to_Z**3*US%T_to_s**3) + units="W m-2", default=1.0e3, scale=US%W_m2_to_RZ3_T3) call get_param(param_file, mdl, "READ_TIDEAMP", read_tideamp, & "If true, read a file (given by TIDEAMP_FILE) containing "//& diff --git a/src/parameterizations/vertical/MOM_set_diffusivity.F90 b/src/parameterizations/vertical/MOM_set_diffusivity.F90 index 3229a7bf80..30fa1689e1 100644 --- a/src/parameterizations/vertical/MOM_set_diffusivity.F90 +++ b/src/parameterizations/vertical/MOM_set_diffusivity.F90 @@ -2084,7 +2084,7 @@ subroutine set_diffusivity_init(Time, G, GV, US, param_file, diag, CS, int_tide_ call get_param(param_file, mdl, "KD_SMOOTH", CS%Kd_smooth, & "A diapycnal diffusivity that is used to interpolate "//& "more sensible values of T & S into thin layers.", & - default=1.0e-6, scale=US%m_to_Z**2*US%T_to_s) + units="m2 s-1", default=1.0e-6, scale=US%m2_s_to_Z2_T) call get_param(param_file, mdl, "DEBUG", CS%debug, & "If true, write out verbose debugging data.", & @@ -2096,19 +2096,18 @@ subroutine set_diffusivity_init(Time, G, GV, US, param_file, diag, CS, int_tide_ call get_param(param_file, mdl, "DISSIPATION_MIN", CS%dissip_min, & "The minimum dissipation by which to determine a lower "//& - "bound of Kd (a floor).", units="W m-3", default=0.0, & - scale=US%kg_m3_to_R*US%m2_s_to_Z2_T*(US%T_to_s**2)) + "bound of Kd (a floor).", & + units="W m-3", default=0.0, scale=US%W_m2_to_RZ3_T3*US%Z_to_m) call get_param(param_file, mdl, "DISSIPATION_N0", CS%dissip_N0, & "The intercept when N=0 of the N-dependent expression "//& "used to set a minimum dissipation by which to determine "//& "a lower bound of Kd (a floor): A in eps_min = A + B*N.", & - units="W m-3", default=0.0, & - scale=US%kg_m3_to_R*US%m2_s_to_Z2_T*(US%T_to_s**2)) + units="W m-3", default=0.0, scale=US%W_m2_to_RZ3_T3*US%Z_to_m) call get_param(param_file, mdl, "DISSIPATION_N1", CS%dissip_N1, & "The coefficient multiplying N, following Gargett, used to "//& "set a minimum dissipation by which to determine a lower "//& "bound of Kd (a floor): B in eps_min = A + B*N", & - units="J m-3", default=0.0, scale=US%kg_m3_to_R*US%m2_s_to_Z2_T*US%T_to_s) + units="J m-3", default=0.0, scale=US%W_m2_to_RZ3_T3*US%Z_to_m*US%s_to_T) call get_param(param_file, mdl, "DISSIPATION_KD_MIN", CS%dissip_Kd_min, & "The minimum vertical diffusivity applied as a floor.", & units="m2 s-1", default=0.0, scale=US%m2_s_to_Z2_T) diff --git a/src/parameterizations/vertical/MOM_tidal_mixing.F90 b/src/parameterizations/vertical/MOM_tidal_mixing.F90 index 9b5f00be61..27b316e144 100644 --- a/src/parameterizations/vertical/MOM_tidal_mixing.F90 +++ b/src/parameterizations/vertical/MOM_tidal_mixing.F90 @@ -440,7 +440,7 @@ logical function tidal_mixing_init(Time, G, GV, US, param_file, diag, CS) call get_param(param_file, mdl, "TKE_ITIDE_MAX", CS%TKE_itide_max, & "The maximum internal tide energy source available to mix "//& "above the bottom boundary layer with INT_TIDE_DISSIPATION.", & - units="W m-2", default=1.0e3, scale=US%kg_m3_to_R*US%m_to_Z**3*US%T_to_s**3) + units="W m-2", default=1.0e3, scale=US%W_m2_to_RZ3_T3) call get_param(param_file, mdl, "READ_TIDEAMP", read_tideamp, & "If true, read a file (given by TIDEAMP_FILE) containing "//& @@ -509,7 +509,7 @@ logical function tidal_mixing_init(Time, G, GV, US, param_file, diag, CS) filename) call safe_alloc_ptr(CS%TKE_Niku,is,ie,js,je) ; CS%TKE_Niku(:,:) = 0.0 call MOM_read_data(filename, 'TKE_input', CS%TKE_Niku, G%domain, timelevel=1, & ! ??? timelevel -aja - scale=US%kg_m3_to_R*US%m_to_Z**3*US%T_to_s**3) + scale=US%W_m2_to_RZ3_T3) CS%TKE_Niku(:,:) = Niku_scale * CS%TKE_Niku(:,:) call get_param(param_file, mdl, "GAMMA_NIKURASHIN",CS%Gamma_lee, & diff --git a/src/user/SCM_CVMix_tests.F90 b/src/user/SCM_CVMix_tests.F90 index be12f75c38..a63205fede 100644 --- a/src/user/SCM_CVMix_tests.F90 +++ b/src/user/SCM_CVMix_tests.F90 @@ -167,11 +167,11 @@ subroutine SCM_CVMix_tests_surface_forcing_init(Time, G, param_file, CS) call get_param(param_file, mdl, "SCM_TAU_X", & CS%tau_x, "Constant X-dir wind stress "// & "used in the SCM CVMix test surface forcing.", & - units='N/m2', scale=US%kg_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z, fail_if_missing=.true.) + units='N/m2', scale=US%kg_m2s_to_RZ_T*US%m_s_to_L_T, fail_if_missing=.true.) call get_param(param_file, mdl, "SCM_TAU_Y", & CS%tau_y, "Constant y-dir wind stress "// & "used in the SCM CVMix test surface forcing.", & - units='N/m2', scale=US%kg_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z, fail_if_missing=.true.) + units='N/m2', scale=US%kg_m2s_to_RZ_T*US%m_s_to_L_T, fail_if_missing=.true.) endif if (CS%UseHeatFlux) then call get_param(param_file, mdl, "SCM_HEAT_FLUX", & From e089a159fdfb7c2cb143da83d6084e6860147c05 Mon Sep 17 00:00:00 2001 From: Mariana Vertenstein Date: Tue, 7 Apr 2020 12:55:57 -0600 Subject: [PATCH 155/316] bug fix for cesm when restart_option is none --- config_src/nuopc_driver/mom_cap.F90 | 51 +++++++++++++---------------- 1 file changed, 22 insertions(+), 29 deletions(-) diff --git a/config_src/nuopc_driver/mom_cap.F90 b/config_src/nuopc_driver/mom_cap.F90 index 26cff18324..232a97ad41 100644 --- a/config_src/nuopc_driver/mom_cap.F90 +++ b/config_src/nuopc_driver/mom_cap.F90 @@ -1978,6 +1978,7 @@ subroutine ModelSetRunClock(gcomp, rc) restart_ymd = 0 if (cesm_coupled) then + call NUOPC_CompAttributeGet(gcomp, name="restart_option", value=restart_option, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return @@ -2033,40 +2034,29 @@ subroutine ModelSetRunClock(gcomp, rc) endif else restart_option = 'none' - call ESMF_LogWrite(subname//" Set restart option = "//restart_option, & - ESMF_LOGMSG_INFO, rc=rc) - !TODO: Find a better way - !Create but disable the restart_alarm; this is so restart writing can function w or w/o - !restart_n=0 - restart_alarm = ESMF_AlarmCreate(mclock, ringtime=dstopTime, name = "restart_alarm", enabled = .false., rc=rc) - call ESMF_LogWrite(subname//" Restart alarm is Created but Disabled", ESMF_LOGMSG_INFO, rc=rc) + call ESMF_LogWrite(subname//" Set restart option = "//restart_option, ESMF_LOGMSG_INFO, rc=rc) endif endif endif - ! Do not initialize an alarm if the restart option is none - if (restart_option /= 'none') then - call AlarmInit(mclock, & - alarm = restart_alarm, & - option = trim(restart_option), & - opt_n = restart_n, & - opt_ymd = restart_ymd, & - RefTime = mcurrTime, & - alarmname = 'restart_alarm', rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - - call ESMF_AlarmSet(restart_alarm, clock=mclock, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - call ESMF_LogWrite(subname//" Restart alarm is Created and Set", ESMF_LOGMSG_INFO, rc=rc) - end if + call AlarmInit(mclock, & + alarm = restart_alarm, & + option = trim(restart_option), & + opt_n = restart_n, & + opt_ymd = restart_ymd, & + RefTime = mcurrTime, & + alarmname = 'restart_alarm', rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return ! bail out - first_time = .false. + call ESMF_AlarmSet(restart_alarm, clock=mclock, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return ! bail out + call ESMF_LogWrite(subname//" Restart alarm is Created and Set", ESMF_LOGMSG_INFO, rc=rc) ! create a 1-shot alarm at the driver stop time stop_alarm = ESMF_AlarmCreate(mclock, ringtime=dstopTime, name = "stop_alarm", rc=rc) @@ -2076,6 +2066,9 @@ subroutine ModelSetRunClock(gcomp, rc) call ESMF_TimeGet(dstoptime, timestring=timestr, rc=rc) call ESMF_LogWrite("Stop Alarm will ring at : "//trim(timestr), ESMF_LOGMSG_INFO, rc=rc) + + first_time = .false. + endif !-------------------------------- From 6af725f2bdf7176de7ba2ce94016d5819a7616c7 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 8 Apr 2020 11:07:28 -0400 Subject: [PATCH 156/316] +Rescaled the units of fluxes%p_surf Rescaled the units of forces%p_surf, fluxes%p_surf, forces%p_surf_full and fluxes%p_surf_full and related surface pressure variables to [R L2 T-2 ~> Pa] for expanded dimensional consistency testing. All answers are bitwise identical, although there are changes to the rescaled units of elements to two transparent data types. --- .../MOM_surface_forcing_gfdl.F90 | 20 +++++++------- .../mct_driver/mom_surface_forcing_mct.F90 | 18 ++++++++----- .../mom_surface_forcing_nuopc.F90 | 22 +++++++-------- src/core/MOM.F90 | 25 +++++++++-------- src/core/MOM_PressureForce.F90 | 4 +-- src/core/MOM_PressureForce_Montgomery.F90 | 12 ++++----- src/core/MOM_PressureForce_analytic_FV.F90 | 14 +++++----- src/core/MOM_PressureForce_blocked_AFV.F90 | 20 +++++++------- src/core/MOM_dynamics_split_RK2.F90 | 10 +++---- src/core/MOM_dynamics_unsplit.F90 | 4 +-- src/core/MOM_dynamics_unsplit_RK2.F90 | 4 +-- src/core/MOM_forcing_type.F90 | 27 ++++++++++--------- src/diagnostics/MOM_diagnostics.F90 | 10 +++---- src/ice_shelf/MOM_ice_shelf.F90 | 8 +++--- .../vertical/MOM_diabatic_aux.F90 | 6 ++--- .../vertical/MOM_entrain_diffusive.F90 | 2 +- .../vertical/MOM_full_convection.F90 | 6 ++--- .../vertical/MOM_internal_tide_input.F90 | 2 +- .../vertical/MOM_kappa_shear.F90 | 10 +++---- .../vertical/MOM_set_diffusivity.F90 | 2 +- .../vertical/MOM_set_viscosity.F90 | 8 +++--- src/user/dumbbell_surface_forcing.F90 | 16 +++++------ 22 files changed, 125 insertions(+), 125 deletions(-) diff --git a/config_src/coupled_driver/MOM_surface_forcing_gfdl.F90 b/config_src/coupled_driver/MOM_surface_forcing_gfdl.F90 index 3fd9ce7888..f2c0b5eea1 100644 --- a/config_src/coupled_driver/MOM_surface_forcing_gfdl.F90 +++ b/config_src/coupled_driver/MOM_surface_forcing_gfdl.F90 @@ -71,8 +71,8 @@ module MOM_surface_forcing_gfdl real :: latent_heat_fusion !< Latent heat of fusion [J kg-1] real :: latent_heat_vapor !< Latent heat of vaporization [J kg-1] - real :: max_p_surf !< The maximum surface pressure that can be - !! exerted by the atmosphere and floating sea-ice [Pa]. + real :: max_p_surf !< The maximum surface pressure that can be exerted by + !! the atmosphere and floating sea-ice [R L2 T-2 ~> 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 @@ -548,14 +548,14 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, 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_full(i,j) = G%mask2dT(i,j) * US%kg_m3_to_R*US%m_s_to_L_T**2*IOB%p(i-i0,j-j0) fluxes%p_surf(i,j) = MIN(fluxes%p_surf_full(i,j),CS%max_p_surf) if (CS%check_no_land_fluxes) & call check_mask_val_consistency(IOB%p(i-i0,j-j0), G%mask2dT(i,j), i, j, 'p', G) 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_full(i,j) = G%mask2dT(i,j) * US%kg_m3_to_R*US%m_s_to_L_T**2*IOB%p(i-i0,j-j0) fluxes%p_surf(i,j) = fluxes%p_surf_full(i,j) if (CS%check_no_land_fluxes) & call check_mask_val_consistency(IOB%p(i-i0,j-j0), G%mask2dT(i,j), i, j, 'p', G) @@ -673,7 +673,7 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS, dt_ net_mass_src, & ! A temporary of net mass sources [kg m-2 s-1]. ustar_tmp ! A temporary array of ustar values [Z T-1 ~> m s-1]. - real :: I_GEarth ! 1.0 / G_Earth [s2 m-1] + real :: I_GEarth ! Pressure conversion factors times 1.0 / G_Earth [kg m-2 T2 R-1 L-2 ~> s2 m-1] real :: Kv_rho_ice ! (CS%kv_sea_ice / CS%density_sea_ice) [m5 s-1 kg-1] 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] @@ -751,12 +751,12 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS, dt_ 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) + forces%p_surf_full(i,j) = G%mask2dT(i,j) * US%kg_m3_to_R*US%m_s_to_L_T**2*IOB%p(i-i0,j-j0) forces%p_surf(i,j) = MIN(forces%p_surf_full(i,j),CS%max_p_surf) enddo ; enddo else do j=js,je ; do i=is,ie - forces%p_surf_full(i,j) = G%mask2dT(i,j) * IOB%p(i-i0,j-j0) + forces%p_surf_full(i,j) = G%mask2dT(i,j) * US%kg_m3_to_R*US%m_s_to_L_T**2*IOB%p(i-i0,j-j0) forces%p_surf(i,j) = forces%p_surf_full(i,j) enddo ; enddo endif @@ -837,7 +837,7 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS, dt_ if (CS%rigid_sea_ice) then call pass_var(forces%p_surf_full, G%Domain, halo=1) - I_GEarth = 1.0 / CS%G_Earth + I_GEarth = US%RL2_T2_to_Pa / CS%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 @@ -1299,8 +1299,8 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS) "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. No "//& - "limit is applied if a negative value is used.", units="Pa", & - default=-1.0) + "limit is applied if a negative value is used.", & + units="Pa", default=-1.0, scale=US%kg_m3_to_R*US%m_s_to_L_T**2) call get_param(param_file, mdl, "RESTORE_SALINITY", CS%restore_salt, & "If true, the coupled driver will add a globally-balanced "//& "fresh-water flux that drives sea-surface salinity "//& diff --git a/config_src/mct_driver/mom_surface_forcing_mct.F90 b/config_src/mct_driver/mom_surface_forcing_mct.F90 index 38bd54acf1..c017ecbba5 100644 --- a/config_src/mct_driver/mom_surface_forcing_mct.F90 +++ b/config_src/mct_driver/mom_surface_forcing_mct.F90 @@ -68,9 +68,9 @@ module MOM_surface_forcing_mct real :: latent_heat_fusion !< latent heat of fusion [J kg-1] real :: latent_heat_vapor !< latent heat of vaporization [J kg-1] - real :: max_p_surf !< maximum surface pressure that can be - !! exerted by the atmosphere and floating sea-ice, - !! [Pa]. This is needed because the FMS coupling + real :: max_p_surf !< The maximum surface pressure that can be exerted by + !! the atmosphere and floating sea-ice [R L2 T-2 ~> 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. @@ -528,11 +528,13 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, 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) +US%kg_m3_to_R*US%m_s_to_L_T**2*IOB%p(i-i0,j-j0) fluxes%p_surf(i,j) = MIN(fluxes%p_surf_full(i,j),CS%max_p_surf) enddo; enddo else do j=js,je ; do i=is,ie fluxes%p_surf_full(i,j) = G%mask2dT(i,j) * IOB%p(i-i0,j-j0) +US%kg_m3_to_R*US%m_s_to_L_T**2*IOB%p(i-i0,j-j0) fluxes%p_surf(i,j) = fluxes%p_surf_full(i,j) enddo; enddo endif @@ -621,7 +623,7 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS) real :: tau_mag !< magnitude of the wind stress [R Z L T-2 ~> Pa] real :: Pa_conversion ! A unit conversion factor from Pa to the internal wind stress units [R Z L T-2 Pa-1 ~> 1] real :: stress_conversion ! A unit conversion factor from Pa times any stress multiplier [R Z L T-2 Pa-1 ~> 1] - real :: I_GEarth !< 1.0 / G%G_Earth [s2 m-1] + real :: I_GEarth !< Pressure conversion factors times 1.0 / G_Earth [kg m-2 T2 R-1 L-2 ~> s2 m-1] real :: Kv_rho_ice !< (CS%kv_sea_ice / CS%density_sea_ice) [m5 s-1 kg-1] 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] @@ -687,11 +689,13 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS) 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) +US%kg_m3_to_R*US%m_s_to_L_T**2*IOB%p(i-i0,j-j0) forces%p_surf(i,j) = MIN(forces%p_surf_full(i,j),CS%max_p_surf) enddo ; enddo else do j=js,je ; do i=is,ie forces%p_surf_full(i,j) = G%mask2dT(i,j) * IOB%p(i-i0,j-j0) +US%kg_m3_to_R*US%m_s_to_L_T**2*IOB%p(i-i0,j-j0) forces%p_surf(i,j) = forces%p_surf_full(i,j) enddo ; enddo endif @@ -845,7 +849,7 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS) if (CS%rigid_sea_ice) then call pass_var(forces%p_surf_full, G%Domain, halo=1) - I_GEarth = 1.0 / CS%G_Earth + I_GEarth = US%RL2_T2_to_Pa / CS%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 @@ -1077,8 +1081,8 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, restore_salt, "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. No "//& - "limit is applied if a negative value is used.", units="Pa", & - default=-1.0) + "limit is applied if a negative value is used.", & + units="Pa", default=-1.0, scale=US%kg_m3_to_R*US%m_s_to_L_T**2) 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 "//& diff --git a/config_src/nuopc_driver/mom_surface_forcing_nuopc.F90 b/config_src/nuopc_driver/mom_surface_forcing_nuopc.F90 index ab72a830ec..0cc71fcb1c 100644 --- a/config_src/nuopc_driver/mom_surface_forcing_nuopc.F90 +++ b/config_src/nuopc_driver/mom_surface_forcing_nuopc.F90 @@ -69,9 +69,9 @@ module MOM_surface_forcing_nuopc 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 + real :: max_p_surf !< maximum surface pressure that can be exerted by the + !! atmosphere and floating sea-ice [R L2 T-2 ~> 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. @@ -519,12 +519,12 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, 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_full(i,j) = G%mask2dT(i,j) * US%kg_m3_to_R*US%m_s_to_L_T**2*IOB%p(i-i0,j-j0) fluxes%p_surf(i,j) = MIN(fluxes%p_surf_full(i,j),CS%max_p_surf) enddo; enddo else do j=js,je ; do i=is,ie - fluxes%p_surf_full(i,j) = G%mask2dT(i,j) * IOB%p(i-i0,j-j0) + fluxes%p_surf_full(i,j) = G%mask2dT(i,j) * US%kg_m3_to_R*US%m_s_to_L_T**2*IOB%p(i-i0,j-j0) fluxes%p_surf(i,j) = fluxes%p_surf_full(i,j) enddo; enddo endif @@ -613,7 +613,7 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS) real :: tau_mag !< magnitude of the wind stress [R Z L T-2 ~> Pa] real :: Pa_conversion ! A unit conversion factor from Pa to the internal wind stress units [R Z L T-2 Pa-1 ~> 1] real :: stress_conversion ! A unit conversion factor from Pa times any stress multiplier [R Z L T-2 Pa-1 ~> 1] - real :: I_GEarth !< 1.0 / G_Earth [s2 m-1] + real :: I_GEarth !< Pressure conversion factors times 1.0 / G_Earth [kg m-2 T2 R-1 L-2 ~> s2 m-1] 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) @@ -677,12 +677,12 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS) 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) + forces%p_surf_full(i,j) = G%mask2dT(i,j) * US%kg_m3_to_R*US%m_s_to_L_T**2*IOB%p(i-i0,j-j0) forces%p_surf(i,j) = MIN(forces%p_surf_full(i,j),CS%max_p_surf) enddo ; enddo else do j=js,je ; do i=is,ie - forces%p_surf_full(i,j) = G%mask2dT(i,j) * IOB%p(i-i0,j-j0) + forces%p_surf_full(i,j) = G%mask2dT(i,j) * US%kg_m3_to_R*US%m_s_to_L_T**2*IOB%p(i-i0,j-j0) forces%p_surf(i,j) = forces%p_surf_full(i,j) enddo ; enddo endif @@ -840,7 +840,7 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS) if (CS%rigid_sea_ice) then call pass_var(forces%p_surf_full, G%Domain, halo=1) - I_GEarth = 1.0 / CS%g_Earth + I_GEarth = US%RL2_T2_to_Pa / CS%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 @@ -1071,8 +1071,8 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, restore_salt, "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. No "//& - "limit is applied if a negative value is used.", units="Pa", & - default=-1.0) + "limit is applied if a negative value is used.", & + units="Pa", default=-1.0, scale=US%kg_m3_to_R*US%m_s_to_L_T**2) 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 "//& diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index def4fd5197..6d5a49209c 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -264,9 +264,9 @@ module MOM !! 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_... + p_surf_prev => NULL(), & !< surface pressure [R L2 T-2 ~> Pa] at end previous call to step_MOM + p_surf_begin => NULL(), & !< surface pressure [R L2 T-2 ~> Pa] at start of step_MOM_dyn_... + p_surf_end => NULL() !< surface pressure [R L2 T-2 ~> 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 @@ -473,7 +473,7 @@ subroutine step_MOM(forces, fluxes, sfc_state, Time_start, time_int_in, CS, & v => NULL(), & ! v : meridional velocity component [L T-1 ~> m s-1] h => NULL() ! h : layer thickness [H ~> m or kg m-2] real, dimension(:,:), pointer :: & - p_surf => NULL() ! A pointer to the ocean surface pressure [Pa]. + p_surf => NULL() ! A pointer to the ocean surface pressure [R L2 T-2 ~> Pa]. real :: I_wt_ssh ! The inverse of the time weights [T-1 ~> s-1] type(time_type) :: Time_local, end_time_thermo, Time_temp @@ -878,10 +878,10 @@ subroutine step_MOM_dynamics(forces, p_surf_begin, p_surf_end, dt, dt_thermo, & 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, intent in [Pa]. + !! step, intent in [R L2 T-2 ~> Pa]. real, dimension(:,:), pointer :: p_surf_end !< A pointer (perhaps NULL) to the surface !! pressure at the end of this dynamic step, - !! intent in [Pa]. + !! intent in [R L2 T-2 ~> Pa]. real, intent(in) :: dt !< time interval covered by this call [T ~> s]. real, intent(in) :: dt_thermo !< time interval covered by any updates that may !! span multiple dynamics steps [T ~> s]. @@ -2449,8 +2449,7 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & endif if (CS%interp_p_surf) then - CS%p_surf_prev_set = & - query_initialized(CS%p_surf_prev,"p_surf_prev",restart_CSp) + CS%p_surf_prev_set = query_initialized(CS%p_surf_prev,"p_surf_prev",restart_CSp) if (CS%p_surf_prev_set) call pass_var(CS%p_surf_prev, G%domain) endif @@ -2683,13 +2682,13 @@ subroutine adjust_ssh_for_p_atm(tv, G, GV, US, ssh, p_atm, use_EOS) type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real, dimension(SZI_(G),SZJ_(G)), intent(inout) :: ssh !< time mean surface height [m] - real, dimension(:,:), optional, pointer :: p_atm !< atmospheric pressure [Pa] + real, dimension(:,:), optional, pointer :: p_atm !< atmospheric pressure [R L2 T-2 ~> Pa] logical, optional, intent(in) :: use_EOS !< If true, calculate the density for !! the SSH correction using the equation of state. real :: Rho_conv ! The density used to convert surface pressure to ! a corrected effective SSH [R ~> kg m-3]. - real :: IgR0 ! The SSH conversion factor from Pa to m [m Pa-1]. + real :: IgR0 ! The SSH conversion factor from R L2 T-2 to m [m T2 R-1 L-2 ~> m Pa-1]. logical :: calc_rho integer :: i, j, is, ie, js, je @@ -2701,12 +2700,12 @@ subroutine adjust_ssh_for_p_atm(tv, G, GV, US, ssh, p_atm, use_EOS) ! atmospheric pressure do j=js,je ; do i=is,ie if (calc_rho) then - call calculate_density(tv%T(i,j,1), tv%S(i,j,1), p_atm(i,j)/2.0, & - Rho_conv, tv%eqn_of_state, scale=US%kg_m3_to_R) + call calculate_density(tv%T(i,j,1), tv%S(i,j,1), p_atm(i,j)/2.0, Rho_conv, & + tv%eqn_of_state, scale=US%kg_m3_to_R, pres_scale=US%RL2_T2_to_Pa) else Rho_conv = GV%Rho0 endif - IgR0 = 1.0 / (Rho_conv * US%R_to_kg_m3*GV%mks_g_Earth) + IgR0 = US%Z_to_m / (Rho_conv * GV%g_Earth) ssh(i,j) = ssh(i,j) + p_atm(i,j) * IgR0 enddo ; enddo endif ; endif diff --git a/src/core/MOM_PressureForce.F90 b/src/core/MOM_PressureForce.F90 index 5579b2311f..6fad3e0d93 100644 --- a/src/core/MOM_PressureForce.F90 +++ b/src/core/MOM_PressureForce.F90 @@ -59,10 +59,10 @@ subroutine PressureForce(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm, pbce, e 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 [Pa]. + !! atmosphere-ocean interface [R L2 T-2 ~> Pa]. real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & optional, intent(out) :: pbce !< The baroclinic pressure anomaly in each layer - !! due to eta anomalies [m2 s-2 H-1 ~> m s-2 or m4 s-2 kg-1]. + !! due to eta anomalies [L2 T-2 H-1 ~> m s-2 or m4 s-2 kg-1]. real, dimension(SZI_(G),SZJ_(G)), & optional, intent(out) :: eta !< The bottom mass used to calculate PFu and PFv, !! [H ~> m or kg m-2], with any tidal contributions. diff --git a/src/core/MOM_PressureForce_Montgomery.F90 b/src/core/MOM_PressureForce_Montgomery.F90 index b8dbfbc6fd..58687b874f 100644 --- a/src/core/MOM_PressureForce_Montgomery.F90 +++ b/src/core/MOM_PressureForce_Montgomery.F90 @@ -71,7 +71,7 @@ subroutine PressureForce_Mont_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, pb !! (equal to -dM/dy) [L T-2 ~> m s-2]. 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 - !! atmosphere-ocean [Pa]. + !! atmosphere-ocean [R L2 T-2 ~> Pa]. 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, @@ -150,7 +150,7 @@ subroutine PressureForce_Mont_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, pb if (use_p_atm) then !$OMP parallel do default(shared) - do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 ; p(i,j,1) = US%kg_m3_to_R*US%m_s_to_L_T**2*p_atm(i,j) ; enddo ; enddo + 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 ; enddo ; enddo @@ -165,7 +165,7 @@ subroutine PressureForce_Mont_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, pb 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) - US%kg_m3_to_R*US%m_s_to_L_T**2*p_atm(i,j)) * Pa_to_H ! eta has the same units as h. + 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) @@ -367,7 +367,7 @@ subroutine PressureForce_Mont_Bouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, pbce, !! (equal to -dM/dy) [L T-2 ~> 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 - !! atmosphere-ocean [Pa]. + !! atmosphere-ocean [R L2 T-2 ~> Pa]. 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 !! [L2 T-2 H-1 ~> m s-2]. @@ -515,7 +515,7 @@ subroutine PressureForce_Mont_Bouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, pbce, do j=Jsq,Jeq+1 do i=Isq,Ieq+1 M(i,j,1) = CS%GFS_scale * (rho_star(i,j,1) * e(i,j,1)) - if (use_p_atm) M(i,j,1) = M(i,j,1) + US%kg_m3_to_R*US%m_s_to_L_T**2*p_atm(i,j) * I_Rho0 + if (use_p_atm) M(i,j,1) = M(i,j,1) + p_atm(i,j) * I_Rho0 enddo do k=2,nz ; do i=Isq,Ieq+1 M(i,j,k) = M(i,j,k-1) + (rho_star(i,j,k) - rho_star(i,j,k-1)) * e(i,j,K) @@ -526,7 +526,7 @@ subroutine PressureForce_Mont_Bouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, pbce, do j=Jsq,Jeq+1 do i=Isq,Ieq+1 M(i,j,1) = GV%g_prime(1) * e(i,j,1) - if (use_p_atm) M(i,j,1) = M(i,j,1) + US%kg_m3_to_R*US%m_s_to_L_T**2*p_atm(i,j) * I_Rho0 + if (use_p_atm) M(i,j,1) = M(i,j,1) + p_atm(i,j) * I_Rho0 enddo do k=2,nz ; do i=Isq,Ieq+1 M(i,j,k) = M(i,j,k-1) + GV%g_prime(K) * e(i,j,K) diff --git a/src/core/MOM_PressureForce_analytic_FV.F90 b/src/core/MOM_PressureForce_analytic_FV.F90 index 6d0465f047..aaab3d822f 100644 --- a/src/core/MOM_PressureForce_analytic_FV.F90 +++ b/src/core/MOM_PressureForce_analytic_FV.F90 @@ -74,7 +74,7 @@ subroutine PressureForce_AFV(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm, pbc 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 [Pa]. + !! or atmosphere-ocean interface [R L2 T-2 ~> Pa]. real, dimension(SZI_(G),SZJ_(G),SZK_(G)), optional, intent(out) :: pbce !< The baroclinic pressure !! anomaly in each layer due to eta anomalies !! [L2 T-2 H-1 ~> m s-2 or m4 s-2 kg-1]. @@ -110,7 +110,7 @@ subroutine PressureForce_AFV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p 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 [Pa]. + !! or atmosphere-ocean interface [R L2 T-2 ~> Pa]. real, dimension(SZI_(G),SZJ_(G),SZK_(G)), optional, intent(out) :: pbce !< The baroclinic pressure !! anomaly in each layer due to eta anomalies !! [L2 T-2 H-1 ~> m s-2 or m4 s-2 kg-1]. @@ -200,7 +200,7 @@ subroutine PressureForce_AFV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p if (use_p_atm) then !$OMP parallel do default(shared) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - p(i,j,1) = US%kg_m3_to_R*US%m_s_to_L_T**2*p_atm(i,j) + p(i,j,1) = p_atm(i,j) enddo ; enddo else !$OMP parallel do default(shared) @@ -414,7 +414,7 @@ subroutine PressureForce_AFV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p 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) - US%kg_m3_to_R*US%m_s_to_L_T**2*p_atm(i,j))*Pa_to_H ! eta has the same units as h. + 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) @@ -447,7 +447,7 @@ subroutine PressureForce_AFV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_at 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 [Pa]. + !! or atmosphere-ocean interface [R L2 T-2 ~> Pa]. real, dimension(SZI_(G),SZJ_(G),SZK_(G)), optional, intent(out) :: pbce !< The baroclinic pressure !! anomaly in each layer due to eta anomalies !! [L2 T-2 H-1 ~> m s-2 or m4 s-2 kg-1]. @@ -602,7 +602,7 @@ subroutine PressureForce_AFV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_at 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, scale=US%kg_m3_to_R) + Isq, Ieq-Isq+2, tv%eqn_of_state, scale=US%kg_m3_to_R, pres_scale=US%RL2_T2_to_Pa) 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, scale=US%kg_m3_to_R) @@ -638,7 +638,7 @@ subroutine PressureForce_AFV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_at 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) + US%kg_m3_to_R*US%m_s_to_L_T**2 * p_atm(i,j) + pa(i,j) = (rho_ref*GV%g_Earth)*e(i,j,1) + p_atm(i,j) enddo ; enddo else !$OMP parallel do default(shared) diff --git a/src/core/MOM_PressureForce_blocked_AFV.F90 b/src/core/MOM_PressureForce_blocked_AFV.F90 index 08951d9eb0..ae50019987 100644 --- a/src/core/MOM_PressureForce_blocked_AFV.F90 +++ b/src/core/MOM_PressureForce_blocked_AFV.F90 @@ -74,7 +74,7 @@ subroutine PressureForce_blk_AFV(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm, 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 [Pa]. + !! or atmosphere-ocean interface [R L2 T-2 ~> Pa]. real, dimension(SZI_(G),SZJ_(G),SZK_(G)), optional, intent(out) :: pbce !< The baroclinic pressure !! anomaly in each layer due to eta anomalies !! [L2 T-2 H-1 ~> m s-2 or m4 s-2 kg-1]. @@ -109,7 +109,7 @@ subroutine PressureForce_blk_AFV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(out) :: PFv !< Meridional acceleration [L T-2 ~> m s-2] 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 [Pa]. + !! or atmosphere-ocean interface [R L2 T-2 ~> Pa]. real, dimension(SZI_(G),SZJ_(G),SZK_(G)), optional, intent(out) :: pbce !< The baroclinic pressure !! anomaly in each layer due to eta anomalies !! [L2 T-2 H-1 ~> m s-2 or m4 s-2 kg-1]. @@ -196,7 +196,7 @@ subroutine PressureForce_blk_AFV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, if (use_p_atm) then !$OMP parallel do default(shared) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - p(i,j,1) = US%kg_m3_to_R*US%m_s_to_L_T**2*p_atm(i,j) + p(i,j,1) = p_atm(i,j) enddo ; enddo else !$OMP parallel do default(shared) @@ -396,7 +396,7 @@ subroutine PressureForce_blk_AFV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, 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) - US%kg_m3_to_R*US%m_s_to_L_T**2*p_atm(i,j))*Pa_to_H ! eta has the same units as h. + 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) @@ -430,7 +430,7 @@ subroutine PressureForce_blk_AFV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, 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 [Pa]. + !! or atmosphere-ocean interface [R L2 T-2 ~> Pa]. real, dimension(SZI_(G),SZJ_(G),SZK_(G)), optional, intent(out) :: pbce !< The baroclinic pressure !! anomaly in each layer due to eta anomalies !! [L2 T-2 H-1 ~> m s-2 or m4 s-2 kg-1]. @@ -587,11 +587,11 @@ subroutine PressureForce_blk_AFV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, !$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, scale=US%kg_m3_to_R) + 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, scale=US%kg_m3_to_R, pres_scale=US%RL2_T2_to_Pa) 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, scale=US%kg_m3_to_R) + 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, scale=US%kg_m3_to_R) endif do i=Isq,Ieq+1 dM(i,j) = (CS%GFS_scale - 1.0) * (G_Rho0 * rho_in_situ(i)) * e(i,j,1) @@ -639,7 +639,7 @@ subroutine PressureForce_blk_AFV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, 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) + US%kg_m3_to_R*US%m_s_to_L_T**2*p_atm(i,j) + 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 diff --git a/src/core/MOM_dynamics_split_RK2.F90 b/src/core/MOM_dynamics_split_RK2.F90 index f4327c2d57..ed74570dab 100644 --- a/src/core/MOM_dynamics_split_RK2.F90 +++ b/src/core/MOM_dynamics_split_RK2.F90 @@ -249,10 +249,10 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, Time_local, dt, forces, p_s type(time_type), intent(in) :: Time_local !< model time at end of time step real, intent(in) :: dt !< time step [T ~> s] 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(:,:), pointer :: p_surf_begin !< surf pressure at the start of this dynamic + !! time step [R L2 T-2 ~> Pa] + real, dimension(:,:), pointer :: p_surf_end !< surf pressure at the end of this dynamic + !! time step [R L2 T-2 ~> Pa] real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), & target, intent(inout) :: uh !< zonal volume/mass transport !! [H L2 T-1 ~> m3 s-1 or kg s-1] @@ -409,7 +409,7 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, Time_local, dt, forces, p_s call PressureForce(h, tv, CS%PFu, CS%PFv, G, GV, US, CS%PressureForce_CSp, & CS%ALE_CSp, p_surf, CS%pbce, CS%eta_PF) if (dyn_p_surf) then - Pa_to_eta = 1.0 / GV%H_to_Pa + Pa_to_eta = US%RL2_T2_to_Pa / GV%H_to_Pa !$OMP parallel do default(shared) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 eta_PF_start(i,j) = CS%eta_PF(i,j) - Pa_to_eta * & diff --git a/src/core/MOM_dynamics_unsplit.F90 b/src/core/MOM_dynamics_unsplit.F90 index a5671948b1..8c6e7d4299 100644 --- a/src/core/MOM_dynamics_unsplit.F90 +++ b/src/core/MOM_dynamics_unsplit.F90 @@ -200,9 +200,9 @@ subroutine step_MOM_dyn_unsplit(u, v, h, tv, visc, Time_local, dt, forces, & real, intent(in) :: dt !< The dynamics time step [T ~> 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 start of this dynamic step [Pa]. + !! pressure at the start of this dynamic step [R L2 T-2 ~> Pa]. real, dimension(:,:), pointer :: p_surf_end !< A pointer (perhaps NULL) to the surface - !! pressure at the end of this dynamic step [Pa]. + !! pressure at the end of this dynamic step [R L2 T-2 ~> Pa]. real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(inout) :: uh !< The zonal volume or mass transport !! [H L2 T-1 ~> m3 s-1 or kg s-1]. real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(inout) :: vh !< The meridional volume or mass diff --git a/src/core/MOM_dynamics_unsplit_RK2.F90 b/src/core/MOM_dynamics_unsplit_RK2.F90 index e88b7c32dc..d3adfaa194 100644 --- a/src/core/MOM_dynamics_unsplit_RK2.F90 +++ b/src/core/MOM_dynamics_unsplit_RK2.F90 @@ -209,10 +209,10 @@ subroutine step_MOM_dyn_unsplit_RK2(u_in, v_in, h_in, tv, visc, Time_local, dt, 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 [Pa]. + !! of this dynamic step [R L2 T-2 ~> Pa]. real, dimension(:,:), pointer :: p_surf_end !< A pointer (perhaps NULL) to !! the surface pressure at the end of - !! this dynamic step [Pa]. + !! this dynamic step [R L2 T-2 ~> Pa]. real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(inout) :: uh !< The zonal volume or mass transport !! [H L2 T-1 ~> m3 s-1 or kg s-1]. real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(inout) :: vh !< The meridional volume or mass diff --git a/src/core/MOM_forcing_type.F90 b/src/core/MOM_forcing_type.F90 index b1b29ee9d3..05d668d866 100644 --- a/src/core/MOM_forcing_type.F90 +++ b/src/core/MOM_forcing_type.F90 @@ -116,13 +116,13 @@ module MOM_forcing_type ! applied surface pressure from other component models (e.g., atmos, sea ice, land ice) real, pointer, dimension(:,:) :: p_surf_full => NULL() - !< Pressure at the top ocean interface [Pa]. + !< Pressure at the top ocean interface [R L2 T-2 ~> Pa]. !! if there is sea-ice, then p_surf_flux is at ice-ocean interface real, pointer, dimension(:,:) :: p_surf => NULL() - !< Pressure at the top ocean interface [Pa] as used to drive the ocean model. + !< Pressure at the top ocean interface [R L2 T-2 ~> Pa] as used to drive the ocean model. !! If p_surf is limited, p_surf may be smaller than p_surf_full, otherwise they are the same. real, pointer, dimension(:,:) :: p_surf_SSH => NULL() - !< Pressure at the top ocean interface [Pa] that is used in corrections to the sea surface + !< Pressure at the top ocean interface [R L2 T-2 ~> Pa] that is used in corrections to the sea surface !! height field that is passed back to the calling routines. !! p_surf_SSH may point to p_surf or to p_surf_full. logical :: accumulate_p_surf = .false. !< If true, the surface pressure due to the atmosphere @@ -195,14 +195,14 @@ module MOM_forcing_type ! applied surface pressure from other component models (e.g., atmos, sea ice, land ice) real, pointer, dimension(:,:) :: p_surf_full => NULL() - !< Pressure at the top ocean interface [Pa]. + !< Pressure at the top ocean interface [R L2 T-2 ~> Pa]. !! if there is sea-ice, then p_surf_flux is at ice-ocean interface real, pointer, dimension(:,:) :: p_surf => NULL() - !< Pressure at the top ocean interface [Pa] as used to drive the ocean model. + !< Pressure at the top ocean interface [R L2 T-2 ~> Pa] as used to drive the ocean model. !! If p_surf is limited, p_surf may be smaller than p_surf_full, otherwise they are the same. real, pointer, dimension(:,:) :: p_surf_SSH => NULL() - !< Pressure at the top ocean interface that is used in corrections to the sea surface - !! height field that is passed back to the calling routines. + !< Pressure at the top ocean interface [R L2 T-2 ~> Pa] that is used in corrections + !! to the sea surface height field that is passed back to the calling routines. !! p_surf_SSH may point to p_surf or to p_surf_full. ! iceberg related inputs @@ -1063,9 +1063,9 @@ subroutine MOM_forcing_chksum(mesg, fluxes, G, US, haloshift) call hchksum(fluxes%seaice_melt_heat, mesg//" fluxes%seaice_melt_heat", G%HI, & haloshift=hshift, scale=US%QRZ_T_to_W_m2) if (associated(fluxes%p_surf)) & - call hchksum(fluxes%p_surf, mesg//" fluxes%p_surf",G%HI,haloshift=hshift) + call hchksum(fluxes%p_surf, mesg//" fluxes%p_surf", G%HI, haloshift=hshift , scale=US%RL2_T2_to_Pa) if (associated(fluxes%salt_flux)) & - call hchksum(fluxes%salt_flux, mesg//" fluxes%salt_flux",G%HI,haloshift=hshift, scale=RZ_T_conversion) + call hchksum(fluxes%salt_flux, mesg//" fluxes%salt_flux", G%HI, haloshift=hshift, scale=RZ_T_conversion) if (associated(fluxes%TKE_tidal)) & call hchksum(fluxes%TKE_tidal, mesg//" fluxes%TKE_tidal", G%HI, haloshift=hshift, & scale=US%RZ3_T3_to_W_m2) @@ -1118,7 +1118,7 @@ subroutine MOM_mech_forcing_chksum(mesg, forces, G, US, haloshift) call uvchksum(mesg//" forces%tau[xy]", forces%taux, forces%tauy, G%HI, & haloshift=hshift, symmetric=.true., scale=US%RZ_T_to_kg_m2s*US%L_T_to_m_s) if (associated(forces%p_surf)) & - call hchksum(forces%p_surf, mesg//" forces%p_surf",G%HI,haloshift=hshift) + call hchksum(forces%p_surf, mesg//" forces%p_surf", G%HI, haloshift=hshift, scale=US%RL2_T2_to_Pa) if (associated(forces%ustar)) & call hchksum(forces%ustar, mesg//" forces%ustar",G%HI,haloshift=hshift, scale=US%Z_to_m*US%s_to_T) if (associated(forces%rigidity_ice_u) .and. associated(forces%rigidity_ice_v)) & @@ -1265,9 +1265,10 @@ subroutine register_forcing_type_diags(Time, diag, US, use_temperature, handles, endif endif - handles%id_psurf = register_diag_field('ocean_model', 'p_surf', diag%axesT1, Time, & - 'Pressure at ice-ocean or atmosphere-ocean interface', 'Pa', cmor_field_name='pso', & - cmor_long_name='Sea Water Pressure at Sea Water Surface', & + handles%id_psurf = register_diag_field('ocean_model', 'p_surf', diag%axesT1, Time, & + 'Pressure at ice-ocean or atmosphere-ocean interface', & + 'Pa', conversion=US%RL2_T2_to_Pa, cmor_field_name='pso', & + cmor_long_name='Sea Water Pressure at Sea Water Surface', & cmor_standard_name='sea_water_pressure_at_sea_water_surface') handles%id_TKE_tidal = register_diag_field('ocean_model', 'TKE_tidal', diag%axesT1, Time, & diff --git a/src/diagnostics/MOM_diagnostics.F90 b/src/diagnostics/MOM_diagnostics.F90 index 0af64c98ff..2107ca21bc 100644 --- a/src/diagnostics/MOM_diagnostics.F90 +++ b/src/diagnostics/MOM_diagnostics.F90 @@ -208,7 +208,7 @@ subroutine calculate_diagnostic_fields(u, v, h, uh, vh, tv, ADp, CDp, p_surf, & !! 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 [Pa]. + real, dimension(:,:), pointer :: p_surf !< A pointer to the surface pressure [R L2 T-2 ~> 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 since the last @@ -345,9 +345,9 @@ subroutine calculate_diagnostic_fields(u, v, h, uh, vh, tv, ADp, CDp, p_surf, & endif else ! thkcello = dp/(rho*g) for non-Boussinesq do j=js,je - if (associated(p_surf)) then ! Pressure loading at top of surface layer [Pa] + if (associated(p_surf)) then ! Pressure loading at top of surface layer [R L2 T-2 ~> Pa] do i=is,ie - pressure_1d(i) = p_surf(i,j) + pressure_1d(i) = US%RL2_T2_to_Pa * p_surf(i,j) enddo else do i=is,ie @@ -769,7 +769,7 @@ subroutine calculate_vertical_integrals(h, tv, p_surf, G, GV, US, CS) intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2]. type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various !! thermodynamic variables. - real, dimension(:,:), pointer :: p_surf !< A pointer to the surface pressure [Pa]. + real, dimension(:,:), pointer :: p_surf !< A pointer to the surface pressure [R L2 T-2 ~> 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 @@ -869,7 +869,7 @@ subroutine calculate_vertical_integrals(h, tv, p_surf, G, GV, US, CS) do j=js,je ; do i=is,ie btm_pres(i,j) = GV%g_Earth * mass(i,j) if (associated(p_surf)) then - btm_pres(i,j) = btm_pres(i,j) + US%kg_m3_to_R*US%m_s_to_L_T**2*p_surf(i,j) + 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) diff --git a/src/ice_shelf/MOM_ice_shelf.F90 b/src/ice_shelf/MOM_ice_shelf.F90 index a0f54efb2d..0117061278 100644 --- a/src/ice_shelf/MOM_ice_shelf.F90 +++ b/src/ice_shelf/MOM_ice_shelf.F90 @@ -803,11 +803,11 @@ subroutine add_shelf_forces(G, US, CS, forces, do_shelf_area) press_ice = (ISS%area_shelf_h(i,j) * US%m_to_L**2*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 + forces%p_surf(i,j) = forces%p_surf(i,j) + US%kg_m3_to_R*US%m_s_to_L_T**2*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 + forces%p_surf_full(i,j) = forces%p_surf_full(i,j) + US%kg_m3_to_R*US%m_s_to_L_T**2*press_ice endif enddo ; enddo @@ -855,11 +855,11 @@ subroutine add_shelf_pressure(G, US, CS, fluxes) press_ice = (CS%ISS%area_shelf_h(i,j) * US%m_to_L**2*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 + fluxes%p_surf(i,j) = fluxes%p_surf(i,j) + US%kg_m3_to_R*US%m_s_to_L_T**2*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 + fluxes%p_surf_full(i,j) = fluxes%p_surf_full(i,j) + US%kg_m3_to_R*US%m_s_to_L_T**2*press_ice endif enddo ; enddo diff --git a/src/parameterizations/vertical/MOM_diabatic_aux.F90 b/src/parameterizations/vertical/MOM_diabatic_aux.F90 index 343423a221..2af57f77c0 100644 --- a/src/parameterizations/vertical/MOM_diabatic_aux.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_aux.F90 @@ -111,7 +111,7 @@ subroutine make_frazil(h, tv, G, GV, US, CS, p_surf, halo) type(diabatic_aux_CS), intent(in) :: CS !< The control structure returned by a previous !! call to diabatic_aux_init. real, dimension(SZI_(G),SZJ_(G)), & - optional, intent(in) :: p_surf !< The pressure at the ocean surface [Pa]. + optional, intent(in) :: p_surf !< The pressure at the ocean surface [R L2 T-2 ~> Pa]. integer, optional, intent(in) :: halo !< Halo width over which to calculate frazil ! Local variables @@ -136,13 +136,13 @@ subroutine make_frazil(h, tv, G, GV, US, CS, p_surf, halo) if (.not.CS%pressure_dependent_frazil) then do k=1,nz ; do i=is,ie ; pressure(i,k) = 0.0 ; enddo ; enddo endif -!$OMP parallel do default(none) shared(is,ie,js,je,CS,G,GV,h,nz,tv,p_surf) & +!$OMP parallel do default(none) shared(is,ie,js,je,CS,G,GV,US,h,nz,tv,p_surf) & !$OMP private(fraz_col,T_fr_set,T_freeze,hc,ps) & !$OMP firstprivate(pressure) !pressure might be set above, so should be firstprivate do j=js,je ps(:) = 0.0 if (PRESENT(p_surf)) then ; do i=is,ie - ps(i) = p_surf(i,j) + ps(i) = US%RL2_T2_to_Pa*p_surf(i,j) enddo ; endif do i=is,ie ; fraz_col(i) = 0.0 ; enddo diff --git a/src/parameterizations/vertical/MOM_entrain_diffusive.F90 b/src/parameterizations/vertical/MOM_entrain_diffusive.F90 index 0fd691e7ab..3413f41389 100644 --- a/src/parameterizations/vertical/MOM_entrain_diffusive.F90 +++ b/src/parameterizations/vertical/MOM_entrain_diffusive.F90 @@ -836,7 +836,7 @@ subroutine entrainment_diffusive(h, tv, fluxes, dt, G, GV, US, CS, ea, eb, & do i=is,ie ; diff_work(i,j,1) = 0.0 ; diff_work(i,j,nz+1) = 0.0 ; enddo if (associated(tv%eqn_of_state)) then if (associated(fluxes%p_surf)) then - do i=is,ie ; pressure(i) = fluxes%p_surf(i,j) ; enddo + do i=is,ie ; pressure(i) = US%RL2_T2_to_Pa*fluxes%p_surf(i,j) ; enddo else do i=is,ie ; pressure(i) = 0.0 ; enddo endif diff --git a/src/parameterizations/vertical/MOM_full_convection.F90 b/src/parameterizations/vertical/MOM_full_convection.F90 index daf41a1ad3..0a023bbebf 100644 --- a/src/parameterizations/vertical/MOM_full_convection.F90 +++ b/src/parameterizations/vertical/MOM_full_convection.F90 @@ -31,7 +31,7 @@ subroutine full_convection(G, GV, US, h, tv, T_adj, S_adj, p_surf, Kddt_smooth, intent(out) :: T_adj !< Adjusted potential temperature [degC]. real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & intent(out) :: S_adj !< Adjusted salinity [ppt]. - real, dimension(:,:), pointer :: p_surf !< The pressure at the ocean surface [Pa] (or NULL). + real, dimension(:,:), pointer :: p_surf !< The pressure at the ocean surface [R L2 T-2 ~> Pa] (or NULL). real, intent(in) :: Kddt_smooth !< A smoothing vertical !! diffusivity times a timestep [H2 ~> m2 or kg2 m-4]. real, optional, intent(in) :: Kddt_convect !< A large convecting vertical @@ -335,7 +335,7 @@ subroutine smoothed_dRdT_dRdS(h, tv, Kddt, dR_dT, dR_dS, G, GV, US, j, p_surf, h !! potential density with salinity [R degC-1 ~> kg m-3 ppt-1] type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type integer, intent(in) :: j !< The j-point to work on. - real, dimension(:,:), pointer :: p_surf !< The pressure at the ocean surface [Pa]. + real, dimension(:,:), pointer :: p_surf !< The pressure at the ocean surface [R L2 T-2 ~> Pa]. integer, optional, intent(in) :: halo !< Halo width over which to compute ! Local variables @@ -403,7 +403,7 @@ subroutine smoothed_dRdT_dRdS(h, tv, Kddt, dR_dT, dR_dS, G, GV, US, j, p_surf, h endif if (associated(p_surf)) then - do i=is,ie ; pres(i) = p_surf(i,j) ; enddo + do i=is,ie ; pres(i) = US%RL2_T2_to_Pa*p_surf(i,j) ; enddo else do i=is,ie ; pres(i) = 0.0 ; enddo endif diff --git a/src/parameterizations/vertical/MOM_internal_tide_input.F90 b/src/parameterizations/vertical/MOM_internal_tide_input.F90 index e37f7a397d..7360853976 100644 --- a/src/parameterizations/vertical/MOM_internal_tide_input.F90 +++ b/src/parameterizations/vertical/MOM_internal_tide_input.F90 @@ -199,7 +199,7 @@ subroutine find_N2_bottom(h, tv, T_f, S_f, h2, fluxes, G, GV, US, N2_bot) do j=js,je if (associated(tv%eqn_of_state)) then if (associated(fluxes%p_surf)) then - do i=is,ie ; pres(i) = fluxes%p_surf(i,j) ; enddo + do i=is,ie ; pres(i) = US%RL2_T2_to_Pa*fluxes%p_surf(i,j) ; enddo else do i=is,ie ; pres(i) = 0.0 ; enddo endif diff --git a/src/parameterizations/vertical/MOM_kappa_shear.F90 b/src/parameterizations/vertical/MOM_kappa_shear.F90 index 77407b6da1..db6aa37e58 100644 --- a/src/parameterizations/vertical/MOM_kappa_shear.F90 +++ b/src/parameterizations/vertical/MOM_kappa_shear.F90 @@ -119,7 +119,7 @@ subroutine Calculate_kappa_shear(u_in, v_in, h, tv, p_surf, kappa_io, tke_io, & type(thermo_var_ptrs), intent(in) :: tv !< A structure containing pointers to any !! available thermodynamic fields. Absent fields !! have NULL ptrs. - real, dimension(:,:), pointer :: p_surf !< The pressure at the ocean surface [Pa] (or NULL). + real, dimension(:,:), pointer :: p_surf !< The pressure at the ocean surface [R L2 T-2 ~> Pa] (or NULL). real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), & intent(inout) :: kappa_io !< The diapycnal diffusivity at each interface !! (not layer!) [Z2 T-1 ~> m2 s-1]. Initially this is the @@ -283,7 +283,7 @@ subroutine Calculate_kappa_shear(u_in, v_in, h, tv, p_surf, kappa_io, tke_io, & endif f2 = 0.25 * ((G%CoriolisBu(I,j)**2 + G%CoriolisBu(I-1,J-1)**2) + & (G%CoriolisBu(I,J-1)**2 + G%CoriolisBu(I-1,J)**2)) - surface_pres = 0.0 ; if (associated(p_surf)) surface_pres = p_surf(i,j) + surface_pres = 0.0 ; if (associated(p_surf)) surface_pres = US%RL2_T2_to_Pa*p_surf(i,j) ! ---------------------------------------------------- I_Ld2_1d, dz_Int_1d @@ -389,7 +389,7 @@ subroutine Calc_kappa_shear_vertex(u_in, v_in, h, T_in, S_in, tv, p_surf, kappa_ type(thermo_var_ptrs), intent(in) :: tv !< A structure containing pointers to any !! available thermodynamic fields. Absent fields !! have NULL ptrs. - real, dimension(:,:), pointer :: p_surf !< The pressure at the ocean surface [Pa] + real, dimension(:,:), pointer :: p_surf !< The pressure at the ocean surface [R L2 T-2 ~> Pa] !! (or NULL). real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), & intent(out) :: kappa_io !< The diapycnal diffusivity at each interface @@ -585,8 +585,8 @@ subroutine Calc_kappa_shear_vertex(u_in, v_in, h, T_in, S_in, tv, p_surf, kappa_ endif f2 = G%CoriolisBu(I,J)**2 surface_pres = 0.0 ; if (associated(p_surf)) & - surface_pres = 0.25 * ((p_surf(i,j) + p_surf(i+1,j+1)) + & - (p_surf(i+1,j) + p_surf(i,j+1))) + surface_pres = 0.25 * US%RL2_T2_to_Pa*((p_surf(i,j) + p_surf(i+1,j+1)) + & + (p_surf(i+1,j) + p_surf(i,j+1))) ! ---------------------------------------------------- ! Set the initial guess for kappa, here defined at interfaces. diff --git a/src/parameterizations/vertical/MOM_set_diffusivity.F90 b/src/parameterizations/vertical/MOM_set_diffusivity.F90 index 30fa1689e1..16305a33e9 100644 --- a/src/parameterizations/vertical/MOM_set_diffusivity.F90 +++ b/src/parameterizations/vertical/MOM_set_diffusivity.F90 @@ -896,7 +896,7 @@ subroutine find_N2(h, tv, T_f, S_f, fluxes, j, G, GV, US, CS, dRho_int, & enddo if (associated(tv%eqn_of_state)) then if (associated(fluxes%p_surf)) then - do i=is,ie ; pres(i) = fluxes%p_surf(i,j) ; enddo + do i=is,ie ; pres(i) = US%RL2_T2_to_Pa*fluxes%p_surf(i,j) ; enddo else do i=is,ie ; pres(i) = 0.0 ; enddo endif diff --git a/src/parameterizations/vertical/MOM_set_viscosity.F90 b/src/parameterizations/vertical/MOM_set_viscosity.F90 index 840059e25a..d58256f9b6 100644 --- a/src/parameterizations/vertical/MOM_set_viscosity.F90 +++ b/src/parameterizations/vertical/MOM_set_viscosity.F90 @@ -1395,8 +1395,8 @@ subroutine set_viscous_ML(u, v, h, tv, forces, visc, dt, G, GV, US, CS, symmetri endif ; enddo ! I-loop if (use_EOS) then - call calculate_density_derivs(T_EOS, S_EOS, forces%p_surf(:,j), & - dR_dT, dR_dS, Isq-G%IsdB+1, Ieq-Isq+1, tv%eqn_of_state, scale=US%kg_m3_to_R) + call calculate_density_derivs(T_EOS, S_EOS, forces%p_surf(:,j), dR_dT, dR_dS, & + Isq-G%IsdB+1, Ieq-Isq+1, tv%eqn_of_state, scale=US%kg_m3_to_R, pres_scale=US%RL2_T2_to_PA) endif do I=Isq,Ieq ; if (do_i(I)) then @@ -1632,8 +1632,8 @@ subroutine set_viscous_ML(u, v, h, tv, forces, visc, dt, G, GV, US, CS, symmetri endif ; enddo ! I-loop if (use_EOS) then - call calculate_density_derivs(T_EOS, S_EOS, forces%p_surf(:,j), & - dR_dT, dR_dS, is-G%IsdB+1, ie-is+1, tv%eqn_of_state, scale=US%kg_m3_to_R) + call calculate_density_derivs(T_EOS, S_EOS, forces%p_surf(:,j), dR_dT, dR_dS, & + is-G%IsdB+1, ie-is+1, tv%eqn_of_state, scale=US%kg_m3_to_R, pres_scale=US%RL2_T2_to_PA) endif do i=is,ie ; if (do_i(i)) then diff --git a/src/user/dumbbell_surface_forcing.F90 b/src/user/dumbbell_surface_forcing.F90 index c1f615fe2a..5be2bc9b8e 100644 --- a/src/user/dumbbell_surface_forcing.F90 +++ b/src/user/dumbbell_surface_forcing.F90 @@ -30,16 +30,15 @@ module dumbbell_surface_forcing real :: Rho0 !< The density used in the Boussinesq approximation [R ~> kg m-3]. real :: G_Earth !< The gravitational acceleration [L2 Z-1 T-2 ~> m s-2] real :: Flux_const !< The restoring rate at the surface [Z T-1 ~> m s-1]. - real :: gust_const !< A constant unresolved background gustiness - !! that contributes to ustar [Pa]. - real :: slp_amplitude !< The amplitude of pressure loading [Pa] applied +! real :: gust_const !< A constant unresolved background gustiness +! !! that contributes to ustar [R L Z T-2 ~> Pa]. + real :: slp_amplitude !< The amplitude of pressure loading [R L2 T-2 ~> Pa] applied !! to the reservoirs - real :: slp_period !< Period of sinusoidal pressure wave + real :: slp_period !< Period of sinusoidal pressure wave [days] real, dimension(:,:), allocatable :: & forcing_mask !< A mask regulating where forcing occurs real, dimension(:,:), allocatable :: & - S_restore !< The surface salinity field toward which to - !! restore [ppt]. + S_restore !< The surface salinity field toward which to restore [ppt]. type(diag_ctrl), pointer :: diag => NULL() !< A structure that is used to regulate the !! timing of diagnostic output. end type dumbbell_surface_forcing_CS @@ -213,10 +212,7 @@ subroutine dumbbell_surface_forcing_init(Time, G, US, param_file, diag, CS) units="kg m-3", default=1035.0, scale=US%kg_m3_to_R) call get_param(param_file, mdl, "DUMBBELL_SLP_AMP", CS%slp_amplitude, & "Amplitude of SLP forcing in reservoirs.", & - units="kg m2 s-1", default = 10000.0) - call get_param(param_file, mdl, "DUMBBELL_SLP_PERIOD", CS%slp_period, & - "Periodicity of SLP forcing in reservoirs.", & - units="days", default = 1.0) + units="Pa", default = 10000.0, scale=US%kg_m3_to_R*US%m_s_to_L_T**2) call get_param(param_file, mdl, "DUMBBELL_SLP_PERIOD", CS%slp_period, & "Periodicity of SLP forcing in reservoirs.", & units="days", default = 1.0) From 978d772bea3e9152324684a869054a5ff97871ce Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Thu, 6 Dec 2018 21:39:46 +0000 Subject: [PATCH 157/316] Moved vkernel unit tests to stdout --- src/framework/MOM_diag_vkernels.F90 | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/src/framework/MOM_diag_vkernels.F90 b/src/framework/MOM_diag_vkernels.F90 index 1b8fb58b6d..43bf73c13d 100644 --- a/src/framework/MOM_diag_vkernels.F90 +++ b/src/framework/MOM_diag_vkernels.F90 @@ -173,8 +173,8 @@ logical function diag_vkernels_unit_tests(verbose) v = verbose - write(0,*) '==== MOM_diag_kernels: diag_vkernels_unit_tests ==========' - if (v) write(0,*) '- - - - - - - - - - interpolation tests - - - - - - - - -' + write(6,*) '==== MOM_diag_kernels: diag_vkernels_unit_tests ==========' + if (v) write(6,*) '- - - - - - - - - - interpolation tests - - - - - - - - -' fail = test_interp(v,mv,'Identity: 3 layer', & 3, (/1.,2.,3./), (/1.,2.,3.,4./), & @@ -302,12 +302,12 @@ logical function test_interp(verbose, missing_value, msg, nsrc, h_src, u_src, nd if (u_dest(k)/=u_true(k)) test_interp = .true. enddo if (verbose .or. test_interp) then - write(0,'(2a)') ' Test: ',msg - write(0,'(a3,3(a24))') 'k','u_result','u_true','error' + write(6,'(2a)') ' Test: ',msg + write(6,'(a3,3(a24))') 'k','u_result','u_true','error' do k=1,ndest+1 error = u_dest(k)-u_true(k) if (error==0.) then - write(0,'(i3,3(1pe24.16))') k,u_dest(k),u_true(k),u_dest(k)-u_true(k) + write(6,'(i3,3(1pe24.16))') k,u_dest(k),u_true(k),u_dest(k)-u_true(k) else write(0,'(i3,3(1pe24.16),x,a)') k,u_dest(k),u_true(k),u_dest(k)-u_true(k),'<--- WRONG!' endif @@ -340,12 +340,12 @@ logical function test_reintegrate(verbose, missing_value, msg, nsrc, h_src, uh_s if (uh_dest(k)/=uh_true(k)) test_reintegrate = .true. enddo if (verbose .or. test_reintegrate) then - write(0,'(2a)') ' Test: ',msg - write(0,'(a3,3(a24))') 'k','uh_result','uh_true','error' + write(6,'(2a)') ' Test: ',msg + write(6,'(a3,3(a24))') 'k','uh_result','uh_true','error' do k=1,ndest error = uh_dest(k)-uh_true(k) if (error==0.) then - write(0,'(i3,3(1pe24.16))') k,uh_dest(k),uh_true(k),uh_dest(k)-uh_true(k) + write(6,'(i3,3(1pe24.16))') k,uh_dest(k),uh_true(k),uh_dest(k)-uh_true(k) else write(0,'(i3,3(1pe24.16),x,a)') k,uh_dest(k),uh_true(k),uh_dest(k)-uh_true(k),'<--- WRONG!' endif From 30063376c92e6351bc98aeb34a746a11ef204e4c Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Wed, 8 Apr 2020 16:01:53 +0000 Subject: [PATCH 158/316] Write test fails to both stderr and stdout - Writing bad results to stderr and good results to stdout means there is no one place to see all results. This puts all results to stdout and in addition writes fails to stderr. - Note that MOM_lateral_boundary_diffusion is incorrectly passing and so the posting to stderr is temporarily commented out (to avoid cluttering all our testing). --- src/ALE/MOM_remapping.F90 | 1 + src/framework/MOM_diag_vkernels.F90 | 4 +++- src/framework/MOM_random.F90 | 2 ++ src/framework/MOM_string_functions.F90 | 10 ++++++++-- src/tracer/MOM_lateral_boundary_diffusion.F90 | 6 +++++- 5 files changed, 19 insertions(+), 4 deletions(-) diff --git a/src/ALE/MOM_remapping.F90 b/src/ALE/MOM_remapping.F90 index 6255a6fce8..e7e1052efe 100644 --- a/src/ALE/MOM_remapping.F90 +++ b/src/ALE/MOM_remapping.F90 @@ -1903,6 +1903,7 @@ logical function test_answer(verbose, n, u, u_true, label, tol) do k = 1, n if (abs(u(k) - u_true(k)) > tolerance) then write(*,'(i4,1p2e24.16,a,1pe24.16,a)') k,u(k),u_true(k),' err=',u(k)-u_true(k),' < wrong' + write(0,'(i4,1p2e24.16,a,1pe24.16,a)') k,u(k),u_true(k),' err=',u(k)-u_true(k),' < wrong' else write(*,'(i4,1p2e24.16)') k,u(k),u_true(k) endif diff --git a/src/framework/MOM_diag_vkernels.F90 b/src/framework/MOM_diag_vkernels.F90 index 43bf73c13d..b134be5bd6 100644 --- a/src/framework/MOM_diag_vkernels.F90 +++ b/src/framework/MOM_diag_vkernels.F90 @@ -221,7 +221,7 @@ logical function diag_vkernels_unit_tests(verbose) 4, (/0.,2.,6.,0./), (/mv,1.,3.,8.,mv/) ) diag_vkernels_unit_tests = diag_vkernels_unit_tests .or. fail - if (v) write(0,*) '- - - - - - - - - - reintegration tests - - - - - - - - -' + if (v) write(6,*) '- - - - - - - - - - reintegration tests - - - - - - - - -' fail = test_reintegrate(v,mv,'Identity: 3 layer', & 3, (/1.,2.,3./), (/-5.,2.,1./), & @@ -309,6 +309,7 @@ logical function test_interp(verbose, missing_value, msg, nsrc, h_src, u_src, nd if (error==0.) then write(6,'(i3,3(1pe24.16))') k,u_dest(k),u_true(k),u_dest(k)-u_true(k) else + write(6,'(i3,3(1pe24.16),x,a)') k,u_dest(k),u_true(k),u_dest(k)-u_true(k),'<--- WRONG!' write(0,'(i3,3(1pe24.16),x,a)') k,u_dest(k),u_true(k),u_dest(k)-u_true(k),'<--- WRONG!' endif enddo @@ -347,6 +348,7 @@ logical function test_reintegrate(verbose, missing_value, msg, nsrc, h_src, uh_s if (error==0.) then write(6,'(i3,3(1pe24.16))') k,uh_dest(k),uh_true(k),uh_dest(k)-uh_true(k) else + write(6,'(i3,3(1pe24.16),x,a)') k,uh_dest(k),uh_true(k),uh_dest(k)-uh_true(k),'<--- WRONG!' write(0,'(i3,3(1pe24.16),x,a)') k,uh_dest(k),uh_true(k),uh_dest(k)-uh_true(k),'<--- WRONG!' endif enddo diff --git a/src/framework/MOM_random.F90 b/src/framework/MOM_random.F90 index 6e254abed2..8dafc530ba 100644 --- a/src/framework/MOM_random.F90 +++ b/src/framework/MOM_random.F90 @@ -417,12 +417,14 @@ logical function test_fn(verbose, good, label, rvalue, ivalue) if (present(ivalue)) then if (.not. good) then + write(6,'(1x,a,i10,1x,a,a)') 'random: result =',ivalue,label,' <------- FAIL!' write(0,'(1x,a,i10,1x,a,a)') 'random: result =',ivalue,label,' <------- FAIL!' elseif (verbose) then write(6,'(1x,a,i10,1x,a)') 'random: result =',ivalue,label endif else if (.not. good) then + write(6,'(1x,a,1pe15.8,1x,a,a)') 'random: result =',rvalue,label,' <------- FAIL!' write(0,'(1x,a,1pe15.8,1x,a,a)') 'random: result =',rvalue,label,' <------- FAIL!' elseif (verbose) then write(6,'(1x,a,1pe15.8,1x,a)') 'random: result =',rvalue,label diff --git a/src/framework/MOM_string_functions.F90 b/src/framework/MOM_string_functions.F90 index 0a4058995a..33f9b69376 100644 --- a/src/framework/MOM_string_functions.F90 +++ b/src/framework/MOM_string_functions.F90 @@ -362,7 +362,10 @@ logical function localTestS(verbose,str1,str2) if (trim(str1)/=trim(str2)) localTestS=.true. if (localTestS .or. verbose) then write(*,*) '>'//trim(str1)//'<' - if (localTestS) write(*,*) trim(str1),':',trim(str2), '<-- FAIL' + if (localTestS) then + write(*,*) trim(str1),':',trim(str2), '<-- FAIL' + write(0,*) trim(str1),':',trim(str2), '<-- FAIL' + endif endif end function localTestS @@ -375,7 +378,10 @@ logical function localTestI(verbose,i1,i2) if (i1/=i2) localTestI=.true. if (localTestI .or. verbose) then write(*,*) i1,i2 - if (localTestI) write(*,*) i1,'!=',i2, '<-- FAIL' + if (localTestI) then + write(*,*) i1,'!=',i2, '<-- FAIL' + write(0,*) i1,'!=',i2, '<-- FAIL' + endif endif end function localTestI diff --git a/src/tracer/MOM_lateral_boundary_diffusion.F90 b/src/tracer/MOM_lateral_boundary_diffusion.F90 index 82e0d6a559..9c53e0e514 100644 --- a/src/tracer/MOM_lateral_boundary_diffusion.F90 +++ b/src/tracer/MOM_lateral_boundary_diffusion.F90 @@ -993,8 +993,12 @@ logical function test_layer_fluxes(verbose, nk, test_name, F_calc, F_ans) do k=1,nk if ( F_calc(k) /= F_ans(k) ) then test_layer_fluxes = .true. - write(stdunit,*) "UNIT TEST FAILED: ", test_name + write(stdunit,*) "MOM_lateral_boundary_diffusion, UNIT TEST FAILED: ", test_name write(stdunit,10) k, F_calc(k), F_ans(k) + ! ### Once these unit tests are passing, and failures are caught properly, + ! we will post failure notifications to both stdout and stderr. + !write(0,*) "MOM_lateral_boundary_diffusion, UNIT TEST FAILED: ", test_name + !write(0,10) k, F_calc(k), F_ans(k) elseif (verbose) then write(stdunit,10) k, F_calc(k), F_ans(k) endif From 916be3c56ba77e8ccfbcca0a357656058797e701 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 8 Apr 2020 14:13:58 -0400 Subject: [PATCH 159/316] Rescaled ice_shelf_CS%g_Earth like GV%g_Earth Revised the dimensional rescaling of ice_shelf_CS%g_Earth to match GV%g_Earth and ice_shelf_dyn_CS%g_Earth to minimize confusion when examining different parts of the code. Also cancelled out pairs of unit conversion factors when setting the ice shelf contributions to fluxes%p_surf and forces%p_surf. All answers are bitwise identical. --- src/ice_shelf/MOM_ice_shelf.F90 | 29 +++++++++++++---------------- 1 file changed, 13 insertions(+), 16 deletions(-) diff --git a/src/ice_shelf/MOM_ice_shelf.F90 b/src/ice_shelf/MOM_ice_shelf.F90 index 1ab963e63f..36f97a65fa 100644 --- a/src/ice_shelf/MOM_ice_shelf.F90 +++ b/src/ice_shelf/MOM_ice_shelf.F90 @@ -92,7 +92,7 @@ module MOM_ice_shelf real :: ustar_bg !< A minimum value for ustar under ice shelves [Z T-1 ~> m s-1]. real :: cdrag !< drag coefficient under ice shelves [nondim]. - real :: g_Earth !< The gravitational acceleration [Z T-2 ~> m s-2] + real :: g_Earth !< The gravitational acceleration [L2 Z-1 T-2 ~> m s-2] real :: Cp !< The heat capacity of sea water [Q degC-1 ~> J kg-1 degC-1]. real :: Rho_ocn !< A reference ocean density [R ~> kg m-3]. real :: Cp_ice !< The heat capacity of fresh ice [Q degC-1 ~> J kg-1 degC-1]. @@ -371,7 +371,7 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) 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) = US%RZ_to_kg_m2*US%Z_to_m*US%s_to_T**2*CS%g_Earth * ISS%mass_shelf(i,j) ; enddo + do i=is,ie ; p_int(i) = US%RL2_T2_to_Pa*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, & @@ -399,8 +399,8 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) hBL_neut_h_molec = ZETA_N * ((hBL_neut * ustar_h) / (5.0 * CS%kv_molec)) ! Determine the mixed layer buoyancy flux, wB_flux. - dB_dS = (CS%g_Earth / Rhoml(i)) * dR0_dS(i) - dB_dT = (CS%g_Earth / Rhoml(i)) * dR0_dT(i) + dB_dS = (US%L_to_Z**2*CS%g_Earth / Rhoml(i)) * dR0_dS(i) + dB_dT = (US%L_to_Z**2*CS%g_Earth / Rhoml(i)) * dR0_dT(i) ln_neut = 0.0 ; if (hBL_neut_h_molec > 1.0) ln_neut = log(hBL_neut_h_molec) if (CS%find_salt_root) then @@ -776,7 +776,7 @@ subroutine add_shelf_forces(G, US, CS, forces, do_shelf_area) logical, optional, intent(in) :: do_shelf_area !< If true find the shelf-covered areas. real :: kv_rho_ice ! The viscosity of ice divided by its density [m3 s-1 R-1 Z-1 ~> m5 kg-1 s-1]. - real :: press_ice ! The pressure of the ice shelf per unit area of ocean (not ice) [Pa]. + real :: press_ice ! The pressure of the ice shelf per unit area of ocean (not ice) [R L2 T-2 ~> 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 @@ -811,15 +811,14 @@ subroutine add_shelf_forces(G, US, CS, forces, do_shelf_area) endif do j=js,je ; do i=is,ie - press_ice = (ISS%area_shelf_h(i,j) * G%IareaT(i,j)) * & - US%RZ_to_kg_m2*US%Z_to_m*US%s_to_T**2*(CS%g_Earth * ISS%mass_shelf(i,j)) + 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) + US%kg_m3_to_R*US%m_s_to_L_T**2*press_ice + 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) + US%kg_m3_to_R*US%m_s_to_L_T**2*press_ice + forces%p_surf_full(i,j) = forces%p_surf_full(i,j) + press_ice endif enddo ; enddo @@ -855,7 +854,7 @@ subroutine add_shelf_pressure(G, US, CS, fluxes) 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. - real :: press_ice !< The pressure of the ice shelf per unit area of ocean (not ice) [Pa]. + real :: press_ice !< The pressure of the ice shelf per unit area of ocean (not ice) [R L2 T-2 ~> Pa]. integer :: i, j, is, ie, js, je, isd, ied, jsd, jed is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec @@ -864,15 +863,14 @@ subroutine add_shelf_pressure(G, US, CS, fluxes) call MOM_error(FATAL,"add_shelf_pressure: Incompatible ocean and ice shelf grids.") do j=js,je ; do i=is,ie - press_ice = (CS%ISS%area_shelf_h(i,j) * G%IareaT(i,j)) * & - US%RZ_to_kg_m2*US%Z_to_m*US%s_to_T**2*(CS%g_Earth * CS%ISS%mass_shelf(i,j)) + 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) + US%kg_m3_to_R*US%m_s_to_L_T**2*press_ice + 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) + US%kg_m3_to_R*US%m_s_to_L_T**2*press_ice + fluxes%p_surf_full(i,j) = fluxes%p_surf_full(i,j) + press_ice endif enddo ; enddo @@ -890,7 +888,6 @@ subroutine add_shelf_flux(G, US, CS, state, fluxes) real :: frac_shelf !< The fractional area covered by the ice shelf [nondim]. real :: frac_open !< The fractional area of the ocean that is not covered by the ice shelf [nondim]. real :: delta_mass_shelf!< Change in ice shelf mass over one time step [kg s-1] - real :: press_ice !< The pressure of the ice shelf per unit area of ocean (not ice) [Pa]. real :: balancing_flux !< The fresh water flux that balances the integrated melt flux [R Z T-1 ~> kg m-2 s-1] real :: balancing_area !< total area where the balancing flux is applied [m2] type(time_type) :: dTime !< The time step as a time_type @@ -1285,7 +1282,7 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl call get_param(param_file, mdl, "G_EARTH", CS%g_Earth, & "The gravitational acceleration of the Earth.", & - units="m s-2", default = 9.80, scale=US%m_to_Z*US%T_to_s**2) + units="m s-2", default = 9.80, scale=US%m_s_to_L_T**2*US%Z_to_m) call get_param(param_file, mdl, "C_P", CS%Cp, & "The heat capacity of sea water, approximated as a constant. "//& "The default value is from the TEOS-10 definition of conservative temperature.", & From 3767883f3ea5390c1edda7786e54d98b6a142385 Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Wed, 8 Apr 2020 19:14:45 +0000 Subject: [PATCH 160/316] Replaced 0,6 with stderr,stdout - Following @marshallward's suggestion we now use stderr and stdout for directing messages in unit tests. These are set from output_unit and error_unit in iso_fortran_env rather than FMS/mpp.F90. The latter is normally used, and should be for error/warning/note messaging, but in the unit tests we need to be in direct control of where messages appear. --- src/ALE/MOM_remapping.F90 | 20 +++--- src/framework/MOM_diag_vkernels.F90 | 30 +++++---- src/framework/MOM_random.F90 | 16 +++-- src/framework/MOM_string_functions.F90 | 25 ++++--- src/tracer/MOM_lateral_boundary_diffusion.F90 | 10 +-- src/tracer/MOM_neutral_diffusion.F90 | 66 ++++++++++--------- 6 files changed, 92 insertions(+), 75 deletions(-) diff --git a/src/ALE/MOM_remapping.F90 b/src/ALE/MOM_remapping.F90 index e7e1052efe..65cf5b9d55 100644 --- a/src/ALE/MOM_remapping.F90 +++ b/src/ALE/MOM_remapping.F90 @@ -14,6 +14,8 @@ module MOM_remapping use PPM_functions, only : PPM_reconstruction, PPM_boundary_extrapolation use PQM_functions, only : PQM_reconstruction, PQM_boundary_extrapolation_v1 +use iso_fortran_env, only : stdout=>output_unit, stderr=>error_unit + implicit none ; private #include @@ -1899,13 +1901,13 @@ logical function test_answer(verbose, n, u, u_true, label, tol) if (abs(u(k) - u_true(k)) > tolerance) test_answer = .true. enddo if (test_answer .or. verbose) then - write(*,'(a4,2a24,x,a)') 'k','Calculated value','Correct value',label + write(stdout,'(a4,2a24,x,a)') 'k','Calculated value','Correct value',label do k = 1, n if (abs(u(k) - u_true(k)) > tolerance) then - write(*,'(i4,1p2e24.16,a,1pe24.16,a)') k,u(k),u_true(k),' err=',u(k)-u_true(k),' < wrong' - write(0,'(i4,1p2e24.16,a,1pe24.16,a)') k,u(k),u_true(k),' err=',u(k)-u_true(k),' < wrong' + write(stdout,'(i4,1p2e24.16,a,1pe24.16,a)') k,u(k),u_true(k),' err=',u(k)-u_true(k),' < wrong' + write(stderr,'(i4,1p2e24.16,a,1pe24.16,a)') k,u(k),u_true(k),' err=',u(k)-u_true(k),' < wrong' else - write(*,'(i4,1p2e24.16)') k,u(k),u_true(k) + write(stdout,'(i4,1p2e24.16)') k,u(k),u_true(k) endif enddo endif @@ -1919,11 +1921,11 @@ subroutine dumpGrid(n,h,x,u) real, dimension(:), intent(in) :: x !< Interface delta real, dimension(:), intent(in) :: u !< Cell average values integer :: i - write(*,'("i=",20i10)') (i,i=1,n+1) - write(*,'("x=",20es10.2)') (x(i),i=1,n+1) - write(*,'("i=",5x,20i10)') (i,i=1,n) - write(*,'("h=",5x,20es10.2)') (h(i),i=1,n) - write(*,'("u=",5x,20es10.2)') (u(i),i=1,n) + write(stdout,'("i=",20i10)') (i,i=1,n+1) + write(stdout,'("x=",20es10.2)') (x(i),i=1,n+1) + write(stdout,'("i=",5x,20i10)') (i,i=1,n) + write(stdout,'("h=",5x,20es10.2)') (h(i),i=1,n) + write(stdout,'("u=",5x,20es10.2)') (u(i),i=1,n) end subroutine dumpGrid end module MOM_remapping diff --git a/src/framework/MOM_diag_vkernels.F90 b/src/framework/MOM_diag_vkernels.F90 index b134be5bd6..b7c1130521 100644 --- a/src/framework/MOM_diag_vkernels.F90 +++ b/src/framework/MOM_diag_vkernels.F90 @@ -4,6 +4,8 @@ module MOM_diag_vkernels ! This file is part of MOM6. See LICENSE.md for the license. +use iso_fortran_env, only : stdout=>output_unit, stderr=>error_unit + implicit none ; private public diag_vkernels_unit_tests @@ -173,8 +175,8 @@ logical function diag_vkernels_unit_tests(verbose) v = verbose - write(6,*) '==== MOM_diag_kernels: diag_vkernels_unit_tests ==========' - if (v) write(6,*) '- - - - - - - - - - interpolation tests - - - - - - - - -' + write(stdout,*) '==== MOM_diag_kernels: diag_vkernels_unit_tests ==========' + if (v) write(stdout,*) '- - - - - - - - - - interpolation tests - - - - - - - - -' fail = test_interp(v,mv,'Identity: 3 layer', & 3, (/1.,2.,3./), (/1.,2.,3.,4./), & @@ -221,7 +223,7 @@ logical function diag_vkernels_unit_tests(verbose) 4, (/0.,2.,6.,0./), (/mv,1.,3.,8.,mv/) ) diag_vkernels_unit_tests = diag_vkernels_unit_tests .or. fail - if (v) write(6,*) '- - - - - - - - - - reintegration tests - - - - - - - - -' + if (v) write(stdout,*) '- - - - - - - - - - reintegration tests - - - - - - - - -' fail = test_reintegrate(v,mv,'Identity: 3 layer', & 3, (/1.,2.,3./), (/-5.,2.,1./), & @@ -273,7 +275,7 @@ logical function diag_vkernels_unit_tests(verbose) 3, (/0.,0.,0./), (/mv, mv, mv/) ) diag_vkernels_unit_tests = diag_vkernels_unit_tests .or. fail - if (.not. fail) write(*,*) 'Pass' + if (.not. fail) write(stdout,*) 'Pass' end function diag_vkernels_unit_tests @@ -302,15 +304,15 @@ logical function test_interp(verbose, missing_value, msg, nsrc, h_src, u_src, nd if (u_dest(k)/=u_true(k)) test_interp = .true. enddo if (verbose .or. test_interp) then - write(6,'(2a)') ' Test: ',msg - write(6,'(a3,3(a24))') 'k','u_result','u_true','error' + write(stdout,'(2a)') ' Test: ',msg + write(stdout,'(a3,3(a24))') 'k','u_result','u_true','error' do k=1,ndest+1 error = u_dest(k)-u_true(k) if (error==0.) then - write(6,'(i3,3(1pe24.16))') k,u_dest(k),u_true(k),u_dest(k)-u_true(k) + write(stdout,'(i3,3(1pe24.16))') k,u_dest(k),u_true(k),u_dest(k)-u_true(k) else - write(6,'(i3,3(1pe24.16),x,a)') k,u_dest(k),u_true(k),u_dest(k)-u_true(k),'<--- WRONG!' - write(0,'(i3,3(1pe24.16),x,a)') k,u_dest(k),u_true(k),u_dest(k)-u_true(k),'<--- WRONG!' + write(stdout,'(i3,3(1pe24.16),x,a)') k,u_dest(k),u_true(k),u_dest(k)-u_true(k),'<--- WRONG!' + write(stderr,'(i3,3(1pe24.16),x,a)') k,u_dest(k),u_true(k),u_dest(k)-u_true(k),'<--- WRONG!' endif enddo endif @@ -341,15 +343,15 @@ logical function test_reintegrate(verbose, missing_value, msg, nsrc, h_src, uh_s if (uh_dest(k)/=uh_true(k)) test_reintegrate = .true. enddo if (verbose .or. test_reintegrate) then - write(6,'(2a)') ' Test: ',msg - write(6,'(a3,3(a24))') 'k','uh_result','uh_true','error' + write(stdout,'(2a)') ' Test: ',msg + write(stdout,'(a3,3(a24))') 'k','uh_result','uh_true','error' do k=1,ndest error = uh_dest(k)-uh_true(k) if (error==0.) then - write(6,'(i3,3(1pe24.16))') k,uh_dest(k),uh_true(k),uh_dest(k)-uh_true(k) + write(stdout,'(i3,3(1pe24.16))') k,uh_dest(k),uh_true(k),uh_dest(k)-uh_true(k) else - write(6,'(i3,3(1pe24.16),x,a)') k,uh_dest(k),uh_true(k),uh_dest(k)-uh_true(k),'<--- WRONG!' - write(0,'(i3,3(1pe24.16),x,a)') k,uh_dest(k),uh_true(k),uh_dest(k)-uh_true(k),'<--- WRONG!' + write(stdout,'(i3,3(1pe24.16),x,a)') k,uh_dest(k),uh_true(k),uh_dest(k)-uh_true(k),'<--- WRONG!' + write(stderr,'(i3,3(1pe24.16),x,a)') k,uh_dest(k),uh_true(k),uh_dest(k)-uh_true(k),'<--- WRONG!' endif enddo endif diff --git a/src/framework/MOM_random.F90 b/src/framework/MOM_random.F90 index 8dafc530ba..c37893012e 100644 --- a/src/framework/MOM_random.F90 +++ b/src/framework/MOM_random.F90 @@ -11,6 +11,8 @@ module MOM_random use MersenneTwister_mod, only : getRandomReal ! Generates a random number use MersenneTwister_mod, only : getRandomPositiveInt ! Generates a random positive integer +use iso_fortran_env, only : stdout=>output_unit, stderr=>error_unit + implicit none ; private public :: random_0d_constructor @@ -205,7 +207,7 @@ logical function random_unit_tests(verbose) HI%jdg_offset = 0 random_unit_tests = .false. - stdunit = 6 + stdunit = stdout write(stdunit,'(1x,a)') '==== MOM_random: random_unit_tests =======================' if (verbose) write(stdunit,'(1x,"random: ",a)') '-- Time-based seeds ---------------------' @@ -417,17 +419,17 @@ logical function test_fn(verbose, good, label, rvalue, ivalue) if (present(ivalue)) then if (.not. good) then - write(6,'(1x,a,i10,1x,a,a)') 'random: result =',ivalue,label,' <------- FAIL!' - write(0,'(1x,a,i10,1x,a,a)') 'random: result =',ivalue,label,' <------- FAIL!' + write(stdout,'(1x,a,i10,1x,a,a)') 'random: result =',ivalue,label,' <------- FAIL!' + write(stderr,'(1x,a,i10,1x,a,a)') 'random: result =',ivalue,label,' <------- FAIL!' elseif (verbose) then - write(6,'(1x,a,i10,1x,a)') 'random: result =',ivalue,label + write(stdout,'(1x,a,i10,1x,a)') 'random: result =',ivalue,label endif else if (.not. good) then - write(6,'(1x,a,1pe15.8,1x,a,a)') 'random: result =',rvalue,label,' <------- FAIL!' - write(0,'(1x,a,1pe15.8,1x,a,a)') 'random: result =',rvalue,label,' <------- FAIL!' + write(stdout,'(1x,a,1pe15.8,1x,a,a)') 'random: result =',rvalue,label,' <------- FAIL!' + write(stderr,'(1x,a,1pe15.8,1x,a,a)') 'random: result =',rvalue,label,' <------- FAIL!' elseif (verbose) then - write(6,'(1x,a,1pe15.8,1x,a)') 'random: result =',rvalue,label + write(stdout,'(1x,a,1pe15.8,1x,a)') 'random: result =',rvalue,label endif endif test_fn = .not. good diff --git a/src/framework/MOM_string_functions.F90 b/src/framework/MOM_string_functions.F90 index 33f9b69376..1293499930 100644 --- a/src/framework/MOM_string_functions.F90 +++ b/src/framework/MOM_string_functions.F90 @@ -3,6 +3,8 @@ module MOM_string_functions ! This file is part of MOM6. See LICENSE.md for the license. +use iso_fortran_env, only : stdout=>output_unit, stderr=>error_unit + implicit none ; private public lowercase, uppercase @@ -319,7 +321,7 @@ logical function string_functions_unit_tests(verbose) logical :: fail, v fail = .false. v = verbose - write(*,*) '==== MOM_string_functions: string_functions_unit_tests ===' + write(stdout,*) '==== MOM_string_functions: string_functions_unit_tests ===' fail = fail .or. localTestS(v,left_int(-1),'-1') fail = fail .or. localTestS(v,left_ints(i(:)),'-1, 1, 3, 3, 0') fail = fail .or. localTestS(v,left_real(0.),'0.0') @@ -349,7 +351,7 @@ logical function string_functions_unit_tests(verbose) fail = fail .or. localTestR(v,extract_real("1.,2.",",",2),2.) fail = fail .or. localTestR(v,extract_real("1.,2.",",",3),0.) fail = fail .or. localTestR(v,extract_real("1.,2.",",",4,4.),4.) - if (.not. fail) write(*,*) 'Pass' + if (.not. fail) write(stdout,*) 'Pass' string_functions_unit_tests = fail end function string_functions_unit_tests @@ -361,10 +363,10 @@ logical function localTestS(verbose,str1,str2) localTestS=.false. if (trim(str1)/=trim(str2)) localTestS=.true. if (localTestS .or. verbose) then - write(*,*) '>'//trim(str1)//'<' + write(stdout,*) '>'//trim(str1)//'<' if (localTestS) then - write(*,*) trim(str1),':',trim(str2), '<-- FAIL' - write(0,*) trim(str1),':',trim(str2), '<-- FAIL' + write(stdout,*) trim(str1),':',trim(str2), '<-- FAIL' + write(stderr,*) trim(str1),':',trim(str2), '<-- FAIL' endif endif end function localTestS @@ -377,10 +379,10 @@ logical function localTestI(verbose,i1,i2) localTestI=.false. if (i1/=i2) localTestI=.true. if (localTestI .or. verbose) then - write(*,*) i1,i2 + write(stdout,*) i1,i2 if (localTestI) then - write(*,*) i1,'!=',i2, '<-- FAIL' - write(0,*) i1,'!=',i2, '<-- FAIL' + write(stdout,*) i1,'!=',i2, '<-- FAIL' + write(stderr,*) i1,'!=',i2, '<-- FAIL' endif endif end function localTestI @@ -393,8 +395,11 @@ logical function localTestR(verbose,r1,r2) localTestR=.false. if (r1/=r2) localTestR=.true. if (localTestR .or. verbose) then - write(*,*) r1,r2 - if (localTestR) write(*,*) r1,'!=',r2, '<-- FAIL' + write(stdout,*) r1,r2 + if (localTestR) then + write(stdout,*) r1,'!=',r2, '<-- FAIL' + write(stderr,*) r1,'!=',r2, '<-- FAIL' + endif endif end function localTestR diff --git a/src/tracer/MOM_lateral_boundary_diffusion.F90 b/src/tracer/MOM_lateral_boundary_diffusion.F90 index 9c53e0e514..443b9108d2 100644 --- a/src/tracer/MOM_lateral_boundary_diffusion.F90 +++ b/src/tracer/MOM_lateral_boundary_diffusion.F90 @@ -24,6 +24,8 @@ module MOM_lateral_boundary_diffusion use MOM_energetic_PBL, only : energetic_PBL_get_MLD, energetic_PBL_CS use MOM_diabatic_driver, only : diabatic_CS, extract_diabatic_member +use iso_fortran_env, only : stdout=>output_unit, stderr=>error_unit + implicit none ; private public near_boundary_unit_tests, lateral_boundary_diffusion, lateral_boundary_diffusion_init @@ -987,7 +989,7 @@ logical function test_layer_fluxes(verbose, nk, test_name, F_calc, F_ans) real, dimension(nk), intent(in) :: F_ans !< Fluxes of the unitless tracer calculated by hand [s^-1] ! Local variables integer :: k - integer, parameter :: stdunit = 6 + integer, parameter :: stdunit = stdout test_layer_fluxes = .false. do k=1,nk @@ -997,8 +999,8 @@ logical function test_layer_fluxes(verbose, nk, test_name, F_calc, F_ans) write(stdunit,10) k, F_calc(k), F_ans(k) ! ### Once these unit tests are passing, and failures are caught properly, ! we will post failure notifications to both stdout and stderr. - !write(0,*) "MOM_lateral_boundary_diffusion, UNIT TEST FAILED: ", test_name - !write(0,10) k, F_calc(k), F_ans(k) + !write(stderr,*) "MOM_lateral_boundary_diffusion, UNIT TEST FAILED: ", test_name + !write(stderr,10) k, F_calc(k), F_ans(k) elseif (verbose) then write(stdunit,10) k, F_calc(k), F_ans(k) endif @@ -1021,7 +1023,7 @@ logical function test_boundary_k_range(k_top, zeta_top, k_bot, zeta_bot, k_top_a character(len=80) :: test_name !< Name of the unit test logical :: verbose !< If true always print output - integer, parameter :: stdunit = 6 + integer, parameter :: stdunit = stdout test_boundary_k_range = k_top .ne. k_top_ans test_boundary_k_range = test_boundary_k_range .or. (zeta_top .ne. zeta_top_ans) diff --git a/src/tracer/MOM_neutral_diffusion.F90 b/src/tracer/MOM_neutral_diffusion.F90 index 26873900cc..cd32f81a32 100644 --- a/src/tracer/MOM_neutral_diffusion.F90 +++ b/src/tracer/MOM_neutral_diffusion.F90 @@ -28,6 +28,9 @@ module MOM_neutral_diffusion use MOM_energetic_PBL, only : energetic_PBL_get_MLD, energetic_PBL_CS use MOM_diabatic_driver, only : diabatic_CS, extract_diabatic_member use MOM_lateral_boundary_diffusion, only : boundary_k_range, SURFACE, BOTTOM + +use iso_fortran_env, only : stdout=>output_unit, stderr=>error_unit + implicit none ; private #include @@ -1120,7 +1123,7 @@ real function interpolate_for_nondim_position(dRhoNeg, Pneg, dRhoPos, Ppos) if (PposdRhoPos) then - write(0,*) 'dRhoNeg, Pneg, dRhoPos, Ppos=',dRhoNeg, Pneg, dRhoPos, Ppos + write(stderr,*) 'dRhoNeg, Pneg, dRhoPos, Ppos=',dRhoNeg, Pneg, dRhoPos, Ppos elseif (dRhoNeg>dRhoPos) then stop 'interpolate_for_nondim_position: Houston, we have a problem! dRhoNeg>dRhoPos' endif @@ -1276,7 +1279,7 @@ subroutine find_neutral_surface_positions_discontinuous(CS, nk, Pres_l, hcol_l, Tr(kl_right, ki_right), Sr(kl_right, ki_right), Pres_r(kl_right,ki_right), & Tl(kl_left, ki_left), Sl(kl_left, ki_left) , Pres_l(kl_left,ki_left), & dRho) - if (CS%debug) write(*,'(A,I2,A,E12.4,A,I2,A,I2,A,I2,A,I2)') "k_surface=",k_surface," dRho=",dRho, & + if (CS%debug) write(stdout,'(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 @@ -1308,11 +1311,11 @@ subroutine find_neutral_surface_positions_discontinuous(CS, nk, Pres_l, hcol_l, KoL(k_surface) = kl_left if (CS%debug) then - write(*,'(A,I2)') "Searching left layer ", kl_left - write(*,'(A,I2,X,I2)') "Searching from right: ", kl_right, ki_right - write(*,*) "Temp/Salt Reference: ", Tr(kl_right,ki_right), Sr(kl_right,ki_right) - write(*,*) "Temp/Salt Top L: ", Tl(kl_left,1), Sl(kl_left,1) - write(*,*) "Temp/Salt Bot L: ", Tl(kl_left,2), Sl(kl_left,2) + write(stdout,'(A,I2)') "Searching left layer ", kl_left + write(stdout,'(A,I2,X,I2)') "Searching from right: ", kl_right, ki_right + write(stdout,*) "Temp/Salt Reference: ", Tr(kl_right,ki_right), Sr(kl_right,ki_right) + write(stdout,*) "Temp/Salt Top L: ", Tl(kl_left,1), Sl(kl_left,1) + write(stdout,*) "Temp/Salt Bot L: ", Tl(kl_left,2), Sl(kl_left,2) endif call increment_interface(nk, kl_right, ki_right, reached_bottom, searching_right_column, searching_left_column) lastP_left = PoL(k_surface) @@ -1331,11 +1334,11 @@ subroutine find_neutral_surface_positions_discontinuous(CS, nk, Pres_l, hcol_l, KoR(k_surface) = kl_right if (CS%debug) then - write(*,'(A,I2)') "Searching right layer ", kl_right - write(*,'(A,I2,X,I2)') "Searching from left: ", kl_left, ki_left - write(*,*) "Temp/Salt Reference: ", Tl(kl_left,ki_left), Sl(kl_left,ki_left) - write(*,*) "Temp/Salt Top L: ", Tr(kl_right,1), Sr(kl_right,1) - write(*,*) "Temp/Salt Bot L: ", Tr(kl_right,2), Sr(kl_right,2) + write(stdout,'(A,I2)') "Searching right layer ", kl_right + write(stdout,'(A,I2,X,I2)') "Searching from left: ", kl_left, ki_left + write(stdout,*) "Temp/Salt Reference: ", Tl(kl_left,ki_left), Sl(kl_left,ki_left) + write(stdout,*) "Temp/Salt Top L: ", Tr(kl_right,1), Sr(kl_right,1) + write(stdout,*) "Temp/Salt Bot L: ", Tr(kl_right,2), Sr(kl_right,2) endif call increment_interface(nk, kl_left, ki_left, reached_bottom, searching_left_column, searching_right_column) lastP_right = PoR(k_surface) @@ -1344,7 +1347,7 @@ subroutine find_neutral_surface_positions_discontinuous(CS, nk, Pres_l, hcol_l, else stop 'Else what?' endif - if (CS%debug) write(*,'(A,I3,A,ES16.6,A,I2,A,ES16.6)') "KoL:", KoL(k_surface), " PoL:", PoL(k_surface), & + if (CS%debug) write(stdout,'(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) endif ! Effective thickness @@ -2039,7 +2042,6 @@ logical function neutral_diffusion_unit_tests(verbose) neutral_diffusion_unit_tests = .false. .or. & ndiff_unit_tests_continuous(verbose) .or. ndiff_unit_tests_discontinuous(verbose) - end function neutral_diffusion_unit_tests !> Returns true if unit tests of neutral_diffusion functions fail. Otherwise returns false. @@ -2064,7 +2066,7 @@ logical function ndiff_unit_tests_continuous(verbose) v = verbose ndiff_unit_tests_continuous = .false. ! Normally return false - write(*,*) '==== MOM_neutral_diffusion: ndiff_unit_tests_continuous =' + write(stdout,*) '==== MOM_neutral_diffusion: ndiff_unit_tests_continuous =' ndiff_unit_tests_continuous = ndiff_unit_tests_continuous .or. & test_fv_diff(v,1.,1.,1., 0.,1.,2., 1., 'FV: Straight line on uniform grid') @@ -2304,7 +2306,7 @@ logical function ndiff_unit_tests_continuous(verbose) (/0.,0.,0.,0.,0.,6.,0./), & ! hEff 'Two unstable mixed layers') - if (.not. ndiff_unit_tests_continuous) write(*,*) 'Pass' + if (.not. ndiff_unit_tests_continuous) write(stdout,*) 'Pass' end function ndiff_unit_tests_continuous @@ -2333,7 +2335,7 @@ logical function ndiff_unit_tests_discontinuous(verbose) v = verbose ndiff_unit_tests_discontinuous = .false. ! Normally return false - write(*,*) '==== MOM_neutral_diffusion: ndiff_unit_tests_discontinuous =' + write(stdout,*) '==== MOM_neutral_diffusion: ndiff_unit_tests_discontinuous =' ! Unit tests for find_neutral_surface_positions_discontinuous ! Salinity is 0 for all these tests @@ -2555,7 +2557,7 @@ logical function ndiff_unit_tests_discontinuous(verbose) find_neutral_pos_linear(CS, 0., 10., 35., 0., 0., 0.8, & 0., 0., 1.0, 10., 0., 0.5, & (/12.,0./), (/34.,2./)), "Salt stratified Linearized Alpha/Beta")) - if (.not. ndiff_unit_tests_discontinuous) write(*,*) 'Pass' + if (.not. ndiff_unit_tests_discontinuous) write(stdout,*) 'Pass' end function ndiff_unit_tests_discontinuous @@ -2579,8 +2581,8 @@ logical function test_fv_diff(verbose, hkm1, hk, hkp1, Skm1, Sk, Skp1, Ptrue, ti test_fv_diff = (Pret /= Ptrue) if (test_fv_diff .or. verbose) then - stdunit = 6 - if (test_fv_diff) stdunit = 0 ! In case of wrong results, write to error stream + stdunit = stdout + if (test_fv_diff) stdunit = stderr ! In case of wrong results, write to error stream write(stdunit,'(a)') title if (test_fv_diff) then write(stdunit,'(2(x,a,f20.16),x,a)') 'pRet=',Pret,'pTrue=',Ptrue,'WRONG!' @@ -2611,8 +2613,8 @@ logical function test_fvlsq_slope(verbose, hkm1, hk, hkp1, Skm1, Sk, Skp1, Ptrue test_fvlsq_slope = (Pret /= Ptrue) if (test_fvlsq_slope .or. verbose) then - stdunit = 6 - if (test_fvlsq_slope) stdunit = 0 ! In case of wrong results, write to error stream + stdunit = stdout + if (test_fvlsq_slope) stdunit = stderr ! In case of wrong results, write to error stream write(stdunit,'(a)') title if (test_fvlsq_slope) then write(stdunit,'(2(x,a,f20.16),x,a)') 'pRet=',Pret,'pTrue=',Ptrue,'WRONG!' @@ -2641,8 +2643,8 @@ logical function test_ifndp(verbose, rhoNeg, Pneg, rhoPos, Ppos, Ptrue, title) test_ifndp = (Pret /= Ptrue) if (test_ifndp .or. verbose) then - stdunit = 6 - if (test_ifndp) stdunit = 0 ! In case of wrong results, write to error stream + stdunit = stdout + if (test_ifndp) stdunit = stderr ! In case of wrong results, write to error stream write(stdunit,'(a)') title if (test_ifndp) then write(stdunit,'(4(x,a,f20.16),2(x,a,1pe22.15),x,a)') & @@ -2672,8 +2674,8 @@ logical function test_data1d(verbose, nk, Po, Ptrue, title) enddo if (test_data1d .or. verbose) then - stdunit = 6 - if (test_data1d) stdunit = 0 ! In case of wrong results, write to error stream + stdunit = stdout + if (test_data1d) stdunit = stderr ! In case of wrong results, write to error stream write(stdunit,'(a)') title do k = 1,nk if (Po(k) /= Ptrue(k)) then @@ -2707,8 +2709,8 @@ logical function test_data1di(verbose, nk, Po, Ptrue, title) enddo if (test_data1di .or. verbose) then - stdunit = 6 - if (test_data1di) stdunit = 0 ! In case of wrong results, write to error stream + stdunit = stdout + if (test_data1di) stdunit = stderr ! In case of wrong results, write to error stream write(stdunit,'(a)') title do k = 1,nk if (Po(k) /= Ptrue(k)) then @@ -2753,8 +2755,8 @@ logical function test_nsp(verbose, ns, KoL, KoR, pL, pR, hEff, KoL0, KoR0, pL0, enddo if (test_nsp .or. verbose) then - stdunit = 6 - if (test_nsp) stdunit = 0 ! In case of wrong results, write to error stream + stdunit = stdout + if (test_nsp) stdunit = stderr ! In case of wrong results, write to error stream write(stdunit,'(a)') title do k = 1,ns this_row_failed = compare_nsp_row(KoL(k), KoR(k), pL(k), pR(k), KoL0(k), KoR0(k), pL0(k), pR0(k)) @@ -2802,7 +2804,9 @@ logical function test_rnp(expected_pos, test_pos, title) 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 + integer :: stdunit + + stdunit = stdout ! Output to standard error test_rnp = ABS(expected_pos - test_pos) > 2*EPSILON(test_pos) if (test_rnp) then write(stdunit,'(A, f20.16, " .neq. ", f20.16, " <-- WRONG")') title, expected_pos, test_pos From 5e1645878c8d258fe51ebb259ea424c527ee612e Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 9 Apr 2020 08:46:39 -0400 Subject: [PATCH 161/316] +Add optional pres_scale arg to calculate_TFreeze Added a new optional pres_scale argument to the calculate_TFreeze interfaces to rescale pressures for dimensional consistency testing. All answers are bitwise identical. --- src/equation_of_state/MOM_EOS.F90 | 86 +++++++++++++++++++------------ 1 file changed, 53 insertions(+), 33 deletions(-) diff --git a/src/equation_of_state/MOM_EOS.F90 b/src/equation_of_state/MOM_EOS.F90 index 5603246ace..d329b718bd 100644 --- a/src/equation_of_state/MOM_EOS.F90 +++ b/src/equation_of_state/MOM_EOS.F90 @@ -166,8 +166,7 @@ subroutine calculate_density_scalar(T, S, pressure, rho, EOS, rho_ref, scale, pr case (EOS_NEMO) call calculate_density_nemo(T, S, p_scale*pressure, rho, rho_ref) case default - call MOM_error(FATAL, & - "calculate_density_scalar: EOS is not valid.") + call MOM_error(FATAL, "calculate_density_scalar: EOS is not valid.") end select if (present(scale)) then ; if (scale /= 1.0) then @@ -214,8 +213,7 @@ subroutine calculate_density_array(T, S, pressure, rho, start, npts, EOS, rho_re case (EOS_NEMO) 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.") + call MOM_error(FATAL, "calculate_density_array: EOS%form_of_EOS is not valid.") end select else do j=start,start+npts-1 ; pres(j) = p_scale * pressure(j) ; enddo @@ -232,8 +230,7 @@ subroutine calculate_density_array(T, S, pressure, rho, start, npts, EOS, rho_re case (EOS_NEMO) call calculate_density_nemo(T, S, pres, rho, start, npts, rho_ref) case default - call MOM_error(FATAL, & - "calculate_density_array: EOS%form_of_EOS is not valid.") + call MOM_error(FATAL, "calculate_density_array: EOS%form_of_EOS is not valid.") end select endif @@ -370,33 +367,38 @@ 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) +subroutine calculate_TFreeze_scalar(S, pressure, T_fr, EOS, pres_scale) real, intent(in) :: S !< Salinity [ppt] real, intent(in) :: pressure !< Pressure [Pa] real, intent(out) :: T_fr !< Freezing point potential temperature referenced !! to the surface [degC] type(EOS_type), pointer :: EOS !< Equation of state structure + real, optional, intent(in) :: pres_scale !< A multiplicative factor to convert pressure into Pa. + + ! Local variables + real :: p_scale ! A factor to convert pressure to units of Pa. if (.not.associated(EOS)) call MOM_error(FATAL, & "calculate_TFreeze_scalar called with an unassociated EOS_type EOS.") + p_scale = 1.0 ; if (present(pres_scale)) p_scale = pres_scale + select case (EOS%form_of_TFreeze) case (TFREEZE_LINEAR) - call calculate_TFreeze_linear(S, pressure, T_fr, EOS%TFr_S0_P0, & + call calculate_TFreeze_linear(S, p_scale*pressure, T_fr, EOS%TFr_S0_P0, & EOS%dTFr_dS, EOS%dTFr_dp) case (TFREEZE_MILLERO) - call calculate_TFreeze_Millero(S, pressure, T_fr) + call calculate_TFreeze_Millero(S, p_scale*pressure, T_fr) case (TFREEZE_TEOS10) - call calculate_TFreeze_teos10(S, pressure, T_fr) + call calculate_TFreeze_teos10(S, p_scale*pressure, T_fr) case default - call MOM_error(FATAL, & - "calculate_TFreeze_scalar: form_of_TFreeze is not valid.") + call MOM_error(FATAL, "calculate_TFreeze_scalar: form_of_TFreeze is not valid.") end select end subroutine calculate_TFreeze_scalar !> Calls the appropriate subroutine to calculate the freezing point for a 1-D array. -subroutine calculate_TFreeze_array(S, pressure, T_fr, start, npts, EOS) +subroutine calculate_TFreeze_array(S, pressure, T_fr, start, npts, EOS, pres_scale) real, dimension(:), intent(in) :: S !< Salinity [ppt] real, dimension(:), intent(in) :: pressure !< Pressure [Pa] real, dimension(:), intent(inout) :: T_fr !< Freezing point potential temperature referenced @@ -404,22 +406,44 @@ subroutine calculate_TFreeze_array(S, pressure, T_fr, start, npts, EOS) 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 + real, optional, intent(in) :: pres_scale !< A multiplicative factor to convert pressure into Pa. + + ! Local variables + real, dimension(size(pressure)) :: pres ! Pressure converted to [Pa] + real :: p_scale ! A factor to convert pressure to units of Pa. + integer :: j if (.not.associated(EOS)) call MOM_error(FATAL, & "calculate_TFreeze_scalar called with an unassociated EOS_type EOS.") - select case (EOS%form_of_TFreeze) - case (TFREEZE_LINEAR) - call calculate_TFreeze_linear(S, pressure, T_fr, start, npts, & - EOS%TFr_S0_P0, EOS%dTFr_dS, EOS%dTFr_dp) - case (TFREEZE_MILLERO) - call calculate_TFreeze_Millero(S, pressure, T_fr, start, npts) - case (TFREEZE_TEOS10) - call calculate_TFreeze_teos10(S, pressure, T_fr, start, npts) - case default - call MOM_error(FATAL, & - "calculate_TFreeze_scalar: form_of_TFreeze is not valid.") - end select + p_scale = 1.0 ; if (present(pres_scale)) p_scale = pres_scale + + if (p_scale == 1.0) then + select case (EOS%form_of_TFreeze) + case (TFREEZE_LINEAR) + call calculate_TFreeze_linear(S, pressure, T_fr, start, npts, & + EOS%TFr_S0_P0, EOS%dTFr_dS, EOS%dTFr_dp) + case (TFREEZE_MILLERO) + call calculate_TFreeze_Millero(S, pressure, T_fr, start, npts) + case (TFREEZE_TEOS10) + call calculate_TFreeze_teos10(S, pressure, T_fr, start, npts) + case default + call MOM_error(FATAL, "calculate_TFreeze_scalar: form_of_TFreeze is not valid.") + end select + else + do j=start,start+npts-1 ; pres(j) = p_scale * pressure(j) ; enddo + select case (EOS%form_of_TFreeze) + case (TFREEZE_LINEAR) + call calculate_TFreeze_linear(S, pres, T_fr, start, npts, & + EOS%TFr_S0_P0, EOS%dTFr_dS, EOS%dTFr_dp) + case (TFREEZE_MILLERO) + call calculate_TFreeze_Millero(S, pres, T_fr, start, npts) + case (TFREEZE_TEOS10) + call calculate_TFreeze_teos10(S, pres, T_fr, start, npts) + case default + call MOM_error(FATAL, "calculate_TFreeze_scalar: form_of_TFreeze is not valid.") + end select + endif end subroutine calculate_TFreeze_array @@ -522,8 +546,7 @@ subroutine calculate_density_derivs_scalar(T, S, pressure, drho_dT, drho_dS, EOS case (EOS_TEOS10) call calculate_density_derivs_teos10(T, S, p_scale*pressure, drho_dT, drho_dS) case default - call MOM_error(FATAL, & - "calculate_density_derivs_scalar: EOS%form_of_EOS is not valid.") + call MOM_error(FATAL, "calculate_density_derivs_scalar: EOS%form_of_EOS is not valid.") end select if (present(scale)) then ; if (scale /= 1.0) then @@ -656,8 +679,7 @@ subroutine calculate_density_second_derivs_scalar(T, S, pressure, drho_dS_dS, dr call calculate_density_second_derivs_teos10(T, S, p_scale*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.") + call MOM_error(FATAL, "calculate_density_derivs: EOS%form_of_EOS is not valid.") end select if (present(scale)) then ; if (scale /= 1.0) then @@ -725,8 +747,7 @@ subroutine calculate_specific_vol_derivs(T, S, pressure, dSV_dT, dSV_dS, start, dSV_dS(j) = -dRho_DS(j)/(rho(j)**2) enddo case default - call MOM_error(FATAL, & - "calculate_density_derivs: EOS%form_of_EOS is not valid.") + call MOM_error(FATAL, "calculate_density_derivs: EOS%form_of_EOS is not valid.") end select if (present(scale)) then ; if (scale /= 1.0) then ; do j=start,start+npts-1 @@ -765,8 +786,7 @@ subroutine calculate_compress_array(T, S, pressure, rho, drho_dp, start, npts, E case (EOS_NEMO) call calculate_compress_nemo(T, S, pressure, rho, drho_dp, start, npts) case default - call MOM_error(FATAL, & - "calculate_compress: EOS%form_of_EOS is not valid.") + call MOM_error(FATAL, "calculate_compress: EOS%form_of_EOS is not valid.") end select end subroutine calculate_compress_array From 1252e3b82594d3241c4b34c4830f3cc951840e1f Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 9 Apr 2020 09:01:46 -0400 Subject: [PATCH 162/316] Pass rescaled pressures to calculate_TFreeze Use the new pres_scale argument to TFreeze and pass rescaled pressures to calculate_TFreeze and several instances of calculate_density. All answers are bitwise identical. --- src/ice_shelf/MOM_ice_shelf.F90 | 26 ++++++++++--------- .../vertical/MOM_diabatic_aux.F90 | 17 +++++++----- .../vertical/MOM_entrain_diffusive.F90 | 10 +++---- .../vertical/MOM_full_convection.F90 | 20 +++++++------- .../vertical/MOM_internal_tide_input.F90 | 10 +++---- .../vertical/MOM_set_diffusivity.F90 | 10 +++---- 6 files changed, 49 insertions(+), 44 deletions(-) diff --git a/src/ice_shelf/MOM_ice_shelf.F90 b/src/ice_shelf/MOM_ice_shelf.F90 index 36f97a65fa..298fbc4507 100644 --- a/src/ice_shelf/MOM_ice_shelf.F90 +++ b/src/ice_shelf/MOM_ice_shelf.F90 @@ -158,7 +158,8 @@ module MOM_ice_shelf logical :: find_salt_root !< If true, if true find Sbdry using a quadratic eq. real :: TFr_0_0 !< The freezing point at 0 pressure and 0 salinity [degC] real :: dTFr_dS !< Partial derivative of freezing temperature with salinity [degC ppt-1] - real :: dTFr_dp !< Partial derivative of freezing temperature with pressure [degC Pa-1] + real :: dTFr_dp !< Partial derivative of freezing temperature with + !! pressure [degC T2 R-1 L-2 ~> degC Pa-1] !>@{ Diagnostic handles integer :: id_melt = -1, id_exch_vel_s = -1, id_exch_vel_t = -1, & id_tfreeze = -1, id_tfl_shelf = -1, & @@ -217,7 +218,7 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) !< with temperature [kg m-3 degC-1]. dR0_dS, & !< Partial derivative of the mixed layer density !< with salinity [kg m-3 ppt-1]. - p_int !< The pressure at the ice-ocean interface [Pa]. + p_int !< The pressure at the ice-ocean interface [R L2 T-2 ~> Pa]. real, dimension(SZI_(CS%grid),SZJ_(CS%grid)) :: & exch_vel_t, & !< Sub-shelf thermal exchange velocity [Z T-1 ~> m s-1] @@ -371,13 +372,13 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) 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) = US%RL2_T2_to_Pa*CS%g_Earth * ISS%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, & - Rhoml(:), is, ie-is+1, CS%eqn_of_state) + Rhoml(:), is, ie-is+1, CS%eqn_of_state, pres_scale=US%RL2_T2_to_Pa) call calculate_density_derivs(state%sst(:,j), state%sss(:,j), p_int, & - dR0_dT, dR0_dS, is, ie-is+1, CS%eqn_of_state) + dR0_dT, dR0_dS, is, ie-is+1, CS%eqn_of_state, pres_scale=US%RL2_T2_to_Pa) do i=is,ie if ((state%ocean_mass(i,j) > US%RZ_to_kg_m2*CS%col_mass_melt_threshold) .and. & @@ -445,7 +446,8 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) do it1 = 1,20 ! Determine the potential temperature at the ice-ocean interface. - call calculate_TFreeze(Sbdry(i,j), p_int(i), ISS%tfreeze(i,j), CS%eqn_of_state) + call calculate_TFreeze(Sbdry(i,j), p_int(i), ISS%tfreeze(i,j), CS%eqn_of_state, & + pres_scale=US%RL2_T2_to_Pa) dT_ustar = (ISS%tfreeze(i,j) - state%sst(i,j)) * ustar_h dS_ustar = (Sbdry(i,j) - state%sss(i,j)) * ustar_h @@ -588,7 +590,8 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) ! 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), ISS%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, & + pres_scale=US%RL2_T2_to_Pa) exch_vel_t(i,j) = CS%gamma_t ISS%tflux_ocn(i,j) = RhoCp * exch_vel_t(i,j) * (ISS%tfreeze(i,j) - state%sst(i,j)) @@ -1272,12 +1275,11 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl "this is the freezing potential temperature at "//& "S=0, P=0.", units="degC", default=0.0, do_not_log=.true.) call get_param(param_file, mdl, "DTFREEZE_DS", CS%dTFr_dS, & - "this is the derivative of the freezing potential "//& - "temperature with salinity.", units="degC psu-1", default=-0.054, do_not_log=.true.) + "this is the derivative of the freezing potential temperature with salinity.", & + units="degC psu-1", default=-0.054, do_not_log=.true.) call get_param(param_file, mdl, "DTFREEZE_DP", CS%dTFr_dp, & - "this is the derivative of the freezing potential "//& - "temperature with pressure.", & - units="degC Pa-1", default=0.0, do_not_log=.true.) + "this is the derivative of the freezing potential temperature with pressure.", & + units="degC Pa-1", default=0.0, scale=US%RL2_T2_to_Pa, do_not_log=.true.) endif call get_param(param_file, mdl, "G_EARTH", CS%g_Earth, & diff --git a/src/parameterizations/vertical/MOM_diabatic_aux.F90 b/src/parameterizations/vertical/MOM_diabatic_aux.F90 index 8fec9a4ca2..1d079d451b 100644 --- a/src/parameterizations/vertical/MOM_diabatic_aux.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_aux.F90 @@ -118,9 +118,10 @@ subroutine make_frazil(h, tv, G, GV, US, CS, p_surf, halo) real, dimension(SZI_(G)) :: & fraz_col, & ! The accumulated heat requirement due to frazil [Q R Z ~> J m-2]. T_freeze, & ! The freezing potential temperature at the current salinity [degC]. - ps ! pressure + ps ! Surface pressure [R L2 T-2 ~> Pa] real, dimension(SZI_(G),SZK_(G)) :: & - pressure ! The pressure at the middle of each layer [Pa]. + pressure ! The pressure at the middle of each layer [R L2 T-2 ~> Pa]. + real :: H_to_RL2_T2 ! A conversion factor from thicknesses in H to pressure [R L2 T-2 H-1 ~> Pa m-1 or Pa m2 kg-1] real :: hc ! A layer's heat capacity [Q R Z degC-1 ~> J m-2 degC-1]. logical :: T_fr_set ! True if the freezing point has been calculated for a ! row of points. @@ -135,6 +136,8 @@ subroutine make_frazil(h, tv, G, GV, US, CS, p_surf, halo) if (.not.CS%pressure_dependent_frazil) then do k=1,nz ; do i=is,ie ; pressure(i,k) = 0.0 ; enddo ; enddo + else + H_to_RL2_T2 = GV%H_to_RZ * GV%g_Earth endif !$OMP parallel do default(none) shared(is,ie,js,je,CS,G,GV,US,h,nz,tv,p_surf) & !$OMP private(fraz_col,T_fr_set,T_freeze,hc,ps) & @@ -142,18 +145,18 @@ subroutine make_frazil(h, tv, G, GV, US, CS, p_surf, halo) do j=js,je ps(:) = 0.0 if (PRESENT(p_surf)) then ; do i=is,ie - ps(i) = US%RL2_T2_to_Pa*p_surf(i,j) + ps(i) = p_surf(i,j) enddo ; endif do i=is,ie ; fraz_col(i) = 0.0 ; enddo if (CS%pressure_dependent_frazil) then do i=is,ie - pressure(i,1) = ps(i) + (0.5*GV%H_to_Pa)*h(i,j,1) + pressure(i,1) = ps(i) + (0.5*H_to_RL2_T2)*h(i,j,1) enddo do k=2,nz ; do i=is,ie pressure(i,k) = pressure(i,k-1) + & - (0.5*GV%H_to_Pa) * (h(i,j,k) + h(i,j,k-1)) + (0.5*H_to_RL2_T2) * (h(i,j,k) + h(i,j,k-1)) enddo ; enddo endif @@ -162,7 +165,7 @@ subroutine make_frazil(h, tv, G, GV, US, CS, p_surf, halo) do i=is,ie ; if (tv%frazil(i,j) > 0.0) then if (.not.T_fr_set) then call calculate_TFreeze(tv%S(i:,j,1), pressure(i:,1), T_freeze(i:), & - 1, ie-i+1, tv%eqn_of_state) + 1, ie-i+1, tv%eqn_of_state, pres_scale=US%RL2_T2_to_Pa) T_fr_set = .true. endif @@ -188,7 +191,7 @@ subroutine make_frazil(h, tv, G, GV, US, CS, p_surf, halo) ((tv%T(i,j,k) < 0.0) .or. (fraz_col(i) > 0.0))) then if (.not.T_fr_set) then call calculate_TFreeze(tv%S(i:,j,k), pressure(i:,k), T_freeze(i:), & - 1, ie-i+1, tv%eqn_of_state) + 1, ie-i+1, tv%eqn_of_state, pres_scale=US%RL2_T2_to_Pa) T_fr_set = .true. endif diff --git a/src/parameterizations/vertical/MOM_entrain_diffusive.F90 b/src/parameterizations/vertical/MOM_entrain_diffusive.F90 index 3413f41389..e5366897e4 100644 --- a/src/parameterizations/vertical/MOM_entrain_diffusive.F90 +++ b/src/parameterizations/vertical/MOM_entrain_diffusive.F90 @@ -174,7 +174,7 @@ subroutine entrainment_diffusive(h, tv, fluxes, dt, G, GV, US, CS, ea, eb, & real :: g_2dt ! 0.5 * G_Earth / dt, times unit conversion factors ! [m3 H-2 s-2 T-1 ~> m s-3 or m7 kg-2 s-3]. real, dimension(SZI_(G)) :: & - pressure, & ! The pressure at an interface [Pa]. + pressure, & ! The pressure at an interface [R L2 T-2 ~> Pa]. T_eos, S_eos, & ! The potential temperature and salinity at which to ! evaluate dRho_dT and dRho_dS [degC] and [ppt]. dRho_dT, dRho_dS ! The partial derivatives of potential density with temperature and @@ -836,12 +836,12 @@ subroutine entrainment_diffusive(h, tv, fluxes, dt, G, GV, US, CS, ea, eb, & do i=is,ie ; diff_work(i,j,1) = 0.0 ; diff_work(i,j,nz+1) = 0.0 ; enddo if (associated(tv%eqn_of_state)) then if (associated(fluxes%p_surf)) then - do i=is,ie ; pressure(i) = US%RL2_T2_to_Pa*fluxes%p_surf(i,j) ; enddo + do i=is,ie ; pressure(i) = fluxes%p_surf(i,j) ; enddo else do i=is,ie ; pressure(i) = 0.0 ; enddo endif do K=2,nz - do i=is,ie ; pressure(i) = pressure(i) + GV%H_to_Pa*h(i,j,k-1) ; enddo + do i=is,ie ; pressure(i) = pressure(i) + (GV%g_Earth*GV%H_to_RZ)*h(i,j,k-1) ; enddo do i=is,ie if (k==kb(i)) then T_eos(i) = 0.5*(tv%T(i,j,kmb) + tv%T(i,j,k)) @@ -851,8 +851,8 @@ subroutine entrainment_diffusive(h, tv, fluxes, dt, G, GV, US, CS, ea, eb, & S_eos(i) = 0.5*(tv%S(i,j,k-1) + tv%S(i,j,k)) endif enddo - call calculate_density_derivs(T_eos, S_eos, pressure, & - dRho_dT, dRho_dS, is, ie-is+1, tv%eqn_of_state, scale=US%kg_m3_to_R) + call calculate_density_derivs(T_eos, S_eos, pressure, dRho_dT, dRho_dS, is, ie-is+1, & + tv%eqn_of_state, scale=US%kg_m3_to_R, pres_scale=US%RL2_T2_to_Pa) do i=is,ie if ((k>kmb) .and. (k Pa]. real :: T_EOS(SZI_(G)) ! Filtered and vertically averaged temperatures [degC] real :: S_EOS(SZI_(G)) ! Filtered and vertically averaged salinities [ppt] real :: kap_dt_x2 ! The product of 2*kappa*dt [H2 ~> m2 or kg2 m-4]. @@ -403,24 +403,24 @@ subroutine smoothed_dRdT_dRdS(h, tv, Kddt, dR_dT, dR_dS, G, GV, US, j, p_surf, h endif if (associated(p_surf)) then - do i=is,ie ; pres(i) = US%RL2_T2_to_Pa*p_surf(i,j) ; enddo + do i=is,ie ; pres(i) = p_surf(i,j) ; enddo else do i=is,ie ; pres(i) = 0.0 ; enddo endif - call calculate_density_derivs(T_f(:,1), S_f(:,1), pres, dR_dT(:,1), dR_dS(:,1), & - is-G%isd+1, ie-is+1, tv%eqn_of_state, scale=US%kg_m3_to_R) - do i=is,ie ; pres(i) = pres(i) + h(i,j,1)*GV%H_to_Pa ; enddo + call calculate_density_derivs(T_f(:,1), S_f(:,1), pres, dR_dT(:,1), dR_dS(:,1), is-G%isd+1, ie-is+1, & + tv%eqn_of_state, scale=US%kg_m3_to_R, pres_scale=US%RL2_T2_to_Pa) + do i=is,ie ; pres(i) = pres(i) + h(i,j,1)*(GV%H_to_RZ*GV%g_Earth) ; enddo do K=2,nz do i=is,ie T_EOS(i) = 0.5*(T_f(i,k-1) + T_f(i,k)) S_EOS(i) = 0.5*(S_f(i,k-1) + S_f(i,k)) enddo - call calculate_density_derivs(T_EOS, S_EOS, pres, dR_dT(:,K), dR_dS(:,K), & - is-G%isd+1, ie-is+1, tv%eqn_of_state, scale=US%kg_m3_to_R) - do i=is,ie ; pres(i) = pres(i) + h(i,j,k)*GV%H_to_Pa ; enddo + call calculate_density_derivs(T_EOS, S_EOS, pres, dR_dT(:,K), dR_dS(:,K), is-G%isd+1, ie-is+1, & + tv%eqn_of_state, scale=US%kg_m3_to_R, pres_scale=US%RL2_T2_to_Pa) + do i=is,ie ; pres(i) = pres(i) + h(i,j,k)*(GV%H_to_RZ*GV%g_Earth) ; enddo enddo - call calculate_density_derivs(T_f(:,nz), S_f(:,nz), pres, dR_dT(:,nz+1), dR_dS(:,nz+1), & - is-G%isd+1, ie-is+1, tv%eqn_of_state, scale=US%kg_m3_to_R) + call calculate_density_derivs(T_f(:,nz), S_f(:,nz), pres, dR_dT(:,nz+1), dR_dS(:,nz+1), is-G%isd+1, & + ie-is+1, tv%eqn_of_state, scale=US%kg_m3_to_R, pres_scale=US%RL2_T2_to_Pa) end subroutine smoothed_dRdT_dRdS diff --git a/src/parameterizations/vertical/MOM_internal_tide_input.F90 b/src/parameterizations/vertical/MOM_internal_tide_input.F90 index a9275c1ccc..6c366e5ff9 100644 --- a/src/parameterizations/vertical/MOM_internal_tide_input.F90 +++ b/src/parameterizations/vertical/MOM_internal_tide_input.F90 @@ -167,7 +167,7 @@ subroutine find_N2_bottom(h, tv, T_f, S_f, h2, fluxes, G, GV, US, N2_bot) real, dimension(SZI_(G),SZK_(G)+1) :: & dRho_int ! The unfiltered density differences across interfaces [R ~> kg m-3]. real, dimension(SZI_(G)) :: & - pres, & ! The pressure at each interface [Pa]. + pres, & ! The pressure at each interface [R L2 T-2 ~> Pa]. Temp_int, & ! The temperature at each interface [degC]. Salin_int, & ! The salinity at each interface [ppt]. drho_bot, & ! The density difference at the bottom of a layer [R ~> kg m-3] @@ -199,18 +199,18 @@ subroutine find_N2_bottom(h, tv, T_f, S_f, h2, fluxes, G, GV, US, N2_bot) do j=js,je if (associated(tv%eqn_of_state)) then if (associated(fluxes%p_surf)) then - do i=is,ie ; pres(i) = US%RL2_T2_to_Pa*fluxes%p_surf(i,j) ; enddo + do i=is,ie ; pres(i) = fluxes%p_surf(i,j) ; enddo else do i=is,ie ; pres(i) = 0.0 ; enddo endif do K=2,nz do i=is,ie - pres(i) = pres(i) + GV%H_to_Pa*h(i,j,k-1) + pres(i) = pres(i) + (GV%g_Earth*GV%H_to_RZ)*h(i,j,k-1) Temp_Int(i) = 0.5 * (T_f(i,j,k) + T_f(i,j,k-1)) Salin_Int(i) = 0.5 * (S_f(i,j,k) + S_f(i,j,k-1)) enddo - call calculate_density_derivs(Temp_int, Salin_int, pres, & - dRho_dT(:), dRho_dS(:), is, ie-is+1, tv%eqn_of_state, scale=US%kg_m3_to_R) + call calculate_density_derivs(Temp_int, Salin_int, pres, dRho_dT(:), dRho_dS(:), & + is, ie-is+1, tv%eqn_of_state, scale=US%kg_m3_to_R, pres_scale=US%RL2_T2_to_Pa) do i=is,ie dRho_int(i,K) = max(dRho_dT(i)*(T_f(i,j,k) - T_f(i,j,k-1)) + & dRho_dS(i)*(S_f(i,j,k) - S_f(i,j,k-1)), 0.0) diff --git a/src/parameterizations/vertical/MOM_set_diffusivity.F90 b/src/parameterizations/vertical/MOM_set_diffusivity.F90 index 4f9a6bf478..9c47841748 100644 --- a/src/parameterizations/vertical/MOM_set_diffusivity.F90 +++ b/src/parameterizations/vertical/MOM_set_diffusivity.F90 @@ -868,7 +868,7 @@ subroutine find_N2(h, tv, T_f, S_f, fluxes, j, G, GV, US, CS, dRho_int, & dRho_dS ! partial derivative of density wrt saln [R ppt-1 ~> kg m-3 ppt-1] real, dimension(SZI_(G)) :: & - pres, & ! pressure at each interface [Pa] + pres, & ! pressure at each interface [R L2 T-2 ~> Pa] Temp_int, & ! temperature at each interface [degC] Salin_int, & ! salinity at each interface [ppt] drho_bot, & ! A density difference [R ~> kg m-3] @@ -896,18 +896,18 @@ subroutine find_N2(h, tv, T_f, S_f, fluxes, j, G, GV, US, CS, dRho_int, & enddo if (associated(tv%eqn_of_state)) then if (associated(fluxes%p_surf)) then - do i=is,ie ; pres(i) = US%RL2_T2_to_Pa*fluxes%p_surf(i,j) ; enddo + do i=is,ie ; pres(i) = fluxes%p_surf(i,j) ; enddo else do i=is,ie ; pres(i) = 0.0 ; enddo endif do K=2,nz do i=is,ie - pres(i) = pres(i) + GV%H_to_Pa*h(i,j,k-1) + pres(i) = pres(i) + (GV%g_Earth*GV%H_to_RZ)*h(i,j,k-1) Temp_Int(i) = 0.5 * (T_f(i,j,k) + T_f(i,j,k-1)) Salin_Int(i) = 0.5 * (S_f(i,j,k) + S_f(i,j,k-1)) enddo - call calculate_density_derivs(Temp_int, Salin_int, pres, & - dRho_dT(:,K), dRho_dS(:,K), is, ie-is+1, tv%eqn_of_state, scale=US%kg_m3_to_R) + call calculate_density_derivs(Temp_int, Salin_int, pres, dRho_dT(:,K), dRho_dS(:,K), & + is, ie-is+1, tv%eqn_of_state, scale=US%kg_m3_to_R, pres_scale=US%RL2_T2_to_Pa) do i=is,ie dRho_int(i,K) = max(dRho_dT(i,K)*(T_f(i,j,k) - T_f(i,j,k-1)) + & dRho_dS(i,K)*(S_f(i,j,k) - S_f(i,j,k-1)), 0.0) From ce0905e17e7fc4b0e1f4f55f6ece1d75234d8826 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 10 Apr 2020 06:03:18 -0400 Subject: [PATCH 163/316] +Add hor_index_type variants of EOS routines Added variants of calculate_density routines that use a hor_index_type to specify array extents and unit_scale_types for dimensional consistency testing, further overloading existing interfaces. Also replaced the recently added rho_scale and pres_scale arguments to int_density_dz with an optional unit_scale_type argument, and modified calls to use this new argument. All answers are bitwise identical, but there are changes to external interfaces. --- src/core/MOM_PressureForce_Montgomery.F90 | 27 +- src/core/MOM_PressureForce_analytic_FV.F90 | 39 +- src/core/MOM_PressureForce_blocked_AFV.F90 | 14 +- src/core/MOM_interface_heights.F90 | 6 +- src/diagnostics/MOM_diagnostics.F90 | 3 +- src/equation_of_state/MOM_EOS.F90 | 722 +++++++++++++++++---- 6 files changed, 627 insertions(+), 184 deletions(-) diff --git a/src/core/MOM_PressureForce_Montgomery.F90 b/src/core/MOM_PressureForce_Montgomery.F90 index 58687b874f..1665e28def 100644 --- a/src/core/MOM_PressureForce_Montgomery.F90 +++ b/src/core/MOM_PressureForce_Montgomery.F90 @@ -186,8 +186,7 @@ subroutine PressureForce_Mont_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, pb !$OMP parallel do default(shared) do k=1,nz call int_specific_vol_dp(tv%T(:,:,k), tv%S(:,:,k), p(:,:,k), p(:,:,k+1), & - 0.0, G%HI, tv%eqn_of_state, dz_geo(:,:,k), halo_size=1, & - SV_scale=US%R_to_kg_m3, pres_scale=US%RL2_T2_to_Pa) + 0.0, G%HI, tv%eqn_of_state, dz_geo(:,:,k), halo_size=1, US=US) enddo !$OMP parallel do default(shared) do j=Jsq,Jeq+1 ; do k=1,nz ; do i=Isq,Ieq+1 @@ -659,8 +658,8 @@ subroutine Set_pbce_Bouss(e, tv, G, GV, US, Rho0, GFS_scale, pbce, rho_star) Ihtot(i) = GV%H_to_Z / ((e(i,j,1)-e(i,j,nz+1)) + z_neglect) press(i) = -Rho0xG*e(i,j,1) enddo - call calculate_density(tv%T(:,j,1), tv%S(:,j,1), press, rho_in_situ, Isq, Ieq-Isq+2, & - tv%eqn_of_state, scale=US%kg_m3_to_R, pres_scale=US%RL2_T2_to_Pa) + call calculate_density(tv%T(:,j,1), tv%S(:,j,1), press, rho_in_situ, G%HI, & + tv%eqn_of_state, US, halo=1) do i=Isq,Ieq+1 pbce(i,j,1) = G_Rho0*(GFS_scale * rho_in_situ(i)) * GV%H_to_Z enddo @@ -670,8 +669,8 @@ subroutine Set_pbce_Bouss(e, tv, G, GV, US, Rho0, GFS_scale, pbce, rho_star) T_int(i) = 0.5*(tv%T(i,j,k-1)+tv%T(i,j,k)) S_int(i) = 0.5*(tv%S(i,j,k-1)+tv%S(i,j,k)) enddo - call calculate_density_derivs(T_int, S_int, press, dR_dT, dR_dS, Isq, Ieq-Isq+2, & - tv%eqn_of_state, scale=US%kg_m3_to_R, pres_scale=US%RL2_T2_to_Pa) + call calculate_density_derivs(T_int, S_int, press, dR_dT, dR_dS, G%HI, & + tv%eqn_of_state, US, halo=1) do i=Isq,Ieq+1 pbce(i,j,k) = pbce(i,j,k-1) + G_Rho0 * & ((e(i,j,K) - e(i,j,nz+1)) * Ihtot(i)) * & @@ -755,9 +754,8 @@ subroutine Set_pbce_nonBouss(p, tv, G, GV, US, GFS_scale, pbce, alpha_star) else !$OMP parallel do default(shared) private(T_int,S_int,dR_dT,dR_dS,rho_in_situ) do j=Jsq,Jeq+1 - call calculate_density(tv%T(:,j,nz), tv%S(:,j,nz), p(:,j,nz+1), rho_in_situ, & - Isq, Ieq-Isq+2, tv%eqn_of_state, scale=US%kg_m3_to_R, & - pres_scale=US%RL2_T2_to_Pa) + call calculate_density(tv%T(:,j,nz), tv%S(:,j,nz), p(:,j,nz+1), rho_in_situ, G%HI, & + tv%eqn_of_state, US, halo=1) do i=Isq,Ieq+1 C_htot(i,j) = dP_dH / ((p(i,j,nz+1)-p(i,j,1)) + dp_neglect) pbce(i,j,nz) = dP_dH / (rho_in_situ(i)) @@ -767,11 +765,12 @@ subroutine Set_pbce_nonBouss(p, tv, G, GV, US, GFS_scale, pbce, alpha_star) T_int(i) = 0.5*(tv%T(i,j,k)+tv%T(i,j,k+1)) S_int(i) = 0.5*(tv%S(i,j,k)+tv%S(i,j,k+1)) enddo - call calculate_density(T_int, S_int, p(:,j,k+1), rho_in_situ, Isq, Ieq-Isq+2, tv%eqn_of_state, & - scale=US%kg_m3_to_R, pres_scale=US%RL2_T2_to_Pa) - call calculate_density_derivs(T_int, S_int, p(:,j,k+1), dR_dT, dR_dS, & - Isq, Ieq-Isq+2, tv%eqn_of_state, & - scale=US%kg_m3_to_R, pres_scale=US%RL2_T2_to_Pa) + call calculate_density(T_int, S_int, p(:,j,k+1), rho_in_situ, G%HI, tv%eqn_of_state, US, halo=1) +! call calculate_density_derivs(T_int, S_int, p(:,j,k+1), dR_dT, dR_dS, & +! Isq, Ieq-Isq+2, tv%eqn_of_state, & +! scale=US%kg_m3_to_R, pres_scale=US%RL2_T2_to_Pa) + call calculate_density_derivs(T_int, S_int, p(:,j,k+1), dR_dT, dR_dS, G%HI, & + tv%eqn_of_state, US, halo=1) do i=Isq,Ieq+1 pbce(i,j,k) = pbce(i,j,k+1) + ((p(i,j,K+1)-p(i,j,1))*C_htot(i,j)) * & ((dR_dT(i)*(tv%T(i,j,k+1)-tv%T(i,j,k)) + & diff --git a/src/core/MOM_PressureForce_analytic_FV.F90 b/src/core/MOM_PressureForce_analytic_FV.F90 index aaab3d822f..10842f9e7e 100644 --- a/src/core/MOM_PressureForce_analytic_FV.F90 +++ b/src/core/MOM_PressureForce_analytic_FV.F90 @@ -264,24 +264,22 @@ subroutine PressureForce_AFV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p 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, & - SV_scale=US%R_to_kg_m3, pres_scale=US%RL2_T2_to_Pa) + tv%eqn_of_state, dza(:,:,k), intp_dza(:,:,k), intx_dza(:,:,k), inty_dza(:,:,k), & + useMassWghtInterp=CS%useMassWghtInterp, US=US) 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)) + ! intx_dza(:,:,k), inty_dza(:,:,k), US=US) 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), bathyP=p(:,:,nz+1), dP_tiny=dp_neglect, & - useMassWghtInterp=CS%useMassWghtInterp, & - SV_scale=US%R_to_kg_m3, pres_scale=US%RL2_T2_to_Pa) + useMassWghtInterp=CS%useMassWghtInterp, US=US) endif else alpha_anom = 1.0 / GV%Rlay(k) - alpha_ref @@ -335,8 +333,8 @@ subroutine PressureForce_AFV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p 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, scale=US%kg_m3_to_R, pres_scale=US%RL2_T2_to_Pa) + call calculate_density(tv_tmp%T(:,j,1), tv_tmp%S(:,j,1), p(:,j,1), rho_in_situ, G%HI, & + tv%eqn_of_state, US, halo=1) 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)) @@ -601,11 +599,11 @@ subroutine PressureForce_AFV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_at !$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, scale=US%kg_m3_to_R, pres_scale=US%RL2_T2_to_Pa) + call calculate_density(tv_tmp%T(:,j,1), tv_tmp%S(:,j,1), p_atm(:,j), rho_in_situ, G%HI, & + tv%eqn_of_state, US, halo=1) 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, scale=US%kg_m3_to_R) + call calculate_density(tv_tmp%T(:,j,1), tv_tmp%S(:,j,1), p0, rho_in_situ, G%HI, & + tv%eqn_of_state, US, halo=1) endif do i=Isq,Ieq+1 dM(i,j) = (CS%GFS_scale - 1.0) * (G_Rho0 * rho_in_situ(i)) * e(i,j,1) @@ -668,20 +666,19 @@ subroutine PressureForce_AFV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_at 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, & - rho_scale=US%kg_m3_to_R, pres_scale=US%RL2_T2_to_Pa) + 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, US=US) 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, & - rho_scale=US%kg_m3_to_R, pres_scale=US%RL2_T2_to_Pa) + 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, US=US) 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%HI, tv%eqn_of_state, & - dpa, intz_dpa, intx_dpa, inty_dpa, G%bathyT, dz_neglect, CS%useMassWghtInterp, & - rho_scale=US%kg_m3_to_R, pres_scale=US%RL2_T2_to_Pa) + 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, US=US) endif !$OMP parallel do default(shared) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 diff --git a/src/core/MOM_PressureForce_blocked_AFV.F90 b/src/core/MOM_PressureForce_blocked_AFV.F90 index ae50019987..c532e17001 100644 --- a/src/core/MOM_PressureForce_blocked_AFV.F90 +++ b/src/core/MOM_PressureForce_blocked_AFV.F90 @@ -248,8 +248,7 @@ subroutine PressureForce_blk_AFV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, 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, & - SV_scale=US%R_to_kg_m3, pres_scale=US%RL2_T2_to_Pa) + useMassWghtInterp=CS%useMassWghtInterp, US=US) else alpha_anom = 1.0 / GV%Rlay(k) - alpha_ref do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 @@ -669,21 +668,18 @@ subroutine PressureForce_blk_AFV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, 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, & - rho_scale=US%kg_m3_to_R, pres_scale=US%RL2_T2_to_Pa) + useMassWghtInterp=CS%useMassWghtInterp, US=US) 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, & - rho_scale=US%kg_m3_to_R, pres_scale=US%RL2_T2_to_Pa) + GV%g_Earth, G%HI, G%Block(n), tv%eqn_of_state, dpa_bk, intz_dpa_bk, & + intx_dpa_bk, inty_dpa_bk, US=US) 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, & - rho_scale=US%kg_m3_to_R, pres_scale=US%RL2_T2_to_Pa) + G%bathyT, dz_neglect, CS%useMassWghtInterp, US=US) 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%Z_to_H diff --git a/src/core/MOM_interface_heights.F90 b/src/core/MOM_interface_heights.F90 index c7147669dd..bfb9ad2703 100644 --- a/src/core/MOM_interface_heights.F90 +++ b/src/core/MOM_interface_heights.F90 @@ -106,8 +106,7 @@ subroutine find_eta_3d(h, tv, G, GV, US, eta, eta_bt, halo_size, eta_to_m) !$OMP do do k=1,nz call int_specific_vol_dp(tv%T(:,:,k), tv%S(:,:,k), p(:,:,K), p(:,:,K+1), & - 0.0, G%HI, tv%eqn_of_state, dz_geo(:,:,k), halo_size=halo, & - SV_scale=US%R_to_kg_m3, pres_scale=US%RL2_T2_to_Pa) + 0.0, G%HI, tv%eqn_of_state, dz_geo(:,:,k), halo_size=halo, US=US) enddo !$OMP do do j=jsv,jev @@ -209,8 +208,7 @@ subroutine find_eta_2d(h, tv, G, GV, US, eta, eta_bt, halo_size, eta_to_m) !$OMP do do k = 1, nz call int_specific_vol_dp(tv%T(:,:,k), tv%S(:,:,k), p(:,:,k), p(:,:,k+1), 0.0, & - G%HI, tv%eqn_of_state, dz_geo(:,:,k), halo_size=halo, & - SV_scale=US%R_to_kg_m3, pres_scale=US%RL2_T2_to_Pa) + G%HI, tv%eqn_of_state, dz_geo(:,:,k), halo_size=halo, US=US) enddo !$OMP do do j=js,je ; do k=1,nz ; do i=is,ie diff --git a/src/diagnostics/MOM_diagnostics.F90 b/src/diagnostics/MOM_diagnostics.F90 index be97723ee2..8c69853f3d 100644 --- a/src/diagnostics/MOM_diagnostics.F90 +++ b/src/diagnostics/MOM_diagnostics.F90 @@ -842,8 +842,7 @@ subroutine calculate_vertical_integrals(h, tv, p_surf, G, GV, US, CS) z_bot(i,j) = z_top(i,j) - GV%H_to_Z*h(i,j,k) enddo ; enddo call int_density_dz(tv%T(:,:,k), tv%S(:,:,k), z_top, z_bot, 0.0, GV%Rho0, GV%g_Earth, & - G%HI, G%HI, tv%eqn_of_state, dpress, rho_scale=US%kg_m3_to_R, & - pres_scale=US%RL2_T2_to_Pa) + G%HI, G%HI, tv%eqn_of_state, dpress, US=US) do j=js,je ; do i=is,ie mass(i,j) = mass(i,j) + dpress(i,j) * IG_Earth enddo ; enddo diff --git a/src/equation_of_state/MOM_EOS.F90 b/src/equation_of_state/MOM_EOS.F90 index d329b718bd..cfd286450e 100644 --- a/src/equation_of_state/MOM_EOS.F90 +++ b/src/equation_of_state/MOM_EOS.F90 @@ -29,8 +29,9 @@ module MOM_EOS 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_hor_index, only : hor_index_type use MOM_string_functions, only : uppercase -use MOM_hor_index, only : hor_index_type +use MOM_unit_scaling, only : unit_scale_type implicit none ; private @@ -58,19 +59,24 @@ module MOM_EOS !> Calculates density of sea water from T, S and P interface calculate_density - module procedure calculate_density_scalar, calculate_density_array + module procedure calculate_density_scalar, calculate_density_array, calculate_density_HI_1d 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 + module procedure calculate_spec_vol_scalar , calculate_spec_vol_array, calculate_spec_vol_HI_1d end interface calculate_spec_vol !> Calculate the derivatives of density with temperature and salinity from T, S, and P interface calculate_density_derivs - module procedure calculate_density_derivs_scalar, calculate_density_derivs_array + module procedure calculate_density_derivs_scalar, calculate_density_derivs_array, & + calculate_density_derivs_HI_1d end interface calculate_density_derivs +interface calculate_specific_vol_derivs + module procedure calculate_spec_vol_derivs_array, calculate_spec_vol_derivs_HI_1d +end interface calculate_specific_vol_derivs + !> Calculates the second derivatives of density with various combinations of temperature, !! salinity, and pressure from T, S and P interface calculate_density_second_derivs @@ -180,7 +186,7 @@ end subroutine calculate_density_scalar subroutine calculate_density_array(T, S, pressure, rho, start, npts, EOS, rho_ref, scale, pres_scale) real, dimension(:), intent(in) :: T !< Potential temperature referenced to the surface [degC] real, dimension(:), intent(in) :: S !< Salinity [ppt] - real, dimension(:), intent(in) :: pressure !< Pressure [Pa] + real, dimension(:), intent(in) :: pressure !< Pressure [Pa] or [other ~> Pa] real, dimension(:), intent(inout) :: rho !< Density (in-situ if pressure is local) [kg m-3] or [R ~> kg m-3] integer, intent(in) :: start !< Start index for computation integer, intent(in) :: npts !< Number of point to compute @@ -240,6 +246,94 @@ subroutine calculate_density_array(T, S, pressure, rho, start, npts, EOS, rho_re end subroutine calculate_density_array +!> Calls the appropriate subroutine to calculate the density of sea water for 1-D array inputs +!! using array extents determined from a hor_index_type. +!! If rho_ref is present, the anomaly with respect to rho_ref is returned. +subroutine calculate_density_HI_1d(T, S, pressure, rho, HI, EOS, US, halo, rho_ref) + type(hor_index_type), intent(in) :: HI !< The horizontal index structure + real, dimension(HI%isd:HI%ied), intent(in) :: T !< Potential temperature referenced to the surface [degC] + real, dimension(HI%isd:HI%ied), intent(in) :: S !< Salinity [ppt] + real, dimension(HI%isd:HI%ied), intent(in) :: pressure !< Pressure [R L2 T-2 ~> Pa] + real, dimension(HI%isd:HI%ied), intent(inout) :: rho !< Density (in-situ if pressure is local) [R ~> kg m-3] + type(EOS_type), pointer :: EOS !< Equation of state structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + integer, optional, intent(in) :: halo !< The halo size to work on; missing is equivalent to 0. + real, optional, intent(in) :: rho_ref !< A reference density [kg m-3]. + + ! Local variables + real, dimension(HI%isd:HI%ied) :: pres ! Pressure converted to [Pa] + real :: rho_reference ! rho_ref converted to [kg m-3] + integer :: i, is, ie, start, npts, halo_sz + + if (.not.associated(EOS)) call MOM_error(FATAL, & + "calculate_density_HI_1d called with an unassociated EOS_type EOS.") + + halo_sz = 0 ; if (present(halo)) halo_sz = halo + + start = HI%isc - (HI%isd-1) - halo_sz + npts = HI%iec - HI%isc + 1 + 2*halo_sz + is = HI%isc - halo_sz ; ie = HI%iec + halo_sz + + if ((US%RL2_T2_to_Pa == 1.0) .and. (US%R_to_kg_M3 == 1.0)) then + 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, rho_ref) + case (EOS_UNESCO) + 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, rho_ref) + case (EOS_TEOS10) + 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, rho_ref) + case default + call MOM_error(FATAL, "calculate_density_HI_1d: EOS%form_of_EOS is not valid.") + end select + elseif (present(rho_ref)) then ! This is the same as above, but with some extra work to rescale variables. + do i=is,ie ; pres(i) = US%RL2_T2_to_Pa * pressure(i) ; enddo + rho_reference = 0.0 ; if (present(rho_ref)) rho_reference = US%R_to_kg_m3*rho_ref + select case (EOS%form_of_EOS) + case (EOS_LINEAR) + call calculate_density_linear(T, S, pres, rho, start, npts, & + EOS%Rho_T0_S0-rho_reference, EOS%dRho_dT, EOS%dRho_dS) + case (EOS_UNESCO) + call calculate_density_unesco(T, S, pres, rho, start, npts, rho_reference) + case (EOS_WRIGHT) + call calculate_density_wright(T, S, pres, rho, start, npts, rho_reference) + case (EOS_TEOS10) + call calculate_density_teos10(T, S, pres, rho, start, npts, rho_reference) + case (EOS_NEMO) + call calculate_density_nemo(T, S, pres, rho, start, npts, rho_reference) + case default + call MOM_error(FATAL, "calculate_density_HI_1d: EOS%form_of_EOS is not valid.") + end select + else ! There is rescaling of variables, but rho_ref is not present. Passing a 0 value of rho_ref + ! changes answers at roundoff for some equations of state, like Wright and UNESCO. + do i=is,ie ; pres(i) = US%RL2_T2_to_Pa * pressure(i) ; enddo + select case (EOS%form_of_EOS) + case (EOS_LINEAR) + call calculate_density_linear(T, S, pres, rho, start, npts, & + EOS%Rho_T0_S0, EOS%dRho_dT, EOS%dRho_dS) + case (EOS_UNESCO) + call calculate_density_unesco(T, S, pres, rho, start, npts) + case (EOS_WRIGHT) + call calculate_density_wright(T, S, pres, rho, start, npts) + case (EOS_TEOS10) + call calculate_density_teos10(T, S, pres, rho, start, npts) + case (EOS_NEMO) + call calculate_density_nemo(T, S, pres, rho, start, npts) + case default + call MOM_error(FATAL, "calculate_density_HI_1d: EOS%form_of_EOS is not valid.") + end select + endif + + if (US%kg_m3_to_R /= 1.0) then ; do i=is,ie + rho(i) = US%kg_m3_to_R * rho(i) + enddo ; endif + +end subroutine calculate_density_HI_1d + !> 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, scale, pres_scale) @@ -288,7 +382,6 @@ subroutine calculate_spec_vol_scalar(T, S, pressure, specvol, EOS, spv_ref, scal 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, scale, pres_scale) @@ -365,6 +458,100 @@ subroutine calculate_spec_vol_array(T, S, pressure, specvol, start, npts, EOS, s end subroutine calculate_spec_vol_array +!> Calls the appropriate subroutine to calculate the specific volume of sea water for 1-D array +!! inputs using array extents determined from a hor_index_type. +subroutine calculate_spec_vol_HI_1d(T, S, pressure, specvol, HI, EOS, US, halo, spv_ref) + type(hor_index_type), intent(in) :: HI !< The horizontal index structure + real, dimension(HI%isd:HI%ied), intent(in) :: T !< Potential temperature referenced to the surface [degC] + real, dimension(HI%isd:HI%ied), intent(in) :: S !< Salinity [ppt] + real, dimension(HI%isd:HI%ied), intent(in) :: pressure !< Pressure [R L2 T-2 ~> Pa] + real, dimension(HI%isd:HI%ied), intent(inout) :: specvol !< In situ specific volume [R-1 ~> m3 kg-1] + type(EOS_type), pointer :: EOS !< Equation of state structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + integer, optional, intent(in) :: halo !< The halo size to work on; missing is equivalent to 0. + real, optional, intent(in) :: spv_ref !< A reference specific volume [R-1 ~> m3 kg-1]. + + ! Local variables + real, dimension(HI%isd:HI%ied) :: pres ! Pressure converted to [Pa] + real, dimension(HI%isd:HI%ied) :: rho ! Density [kg m-3] + real :: spv_reference ! spv_ref converted to [m3 kg-1] + integer :: i, is, ie, start, npts, halo_sz + + if (.not.associated(EOS)) call MOM_error(FATAL, & + "calculate_spec_vol_HI_1d called with an unassociated EOS_type EOS.") + + halo_sz = 0 ; if (present(halo)) halo_sz = halo + + start = HI%isc - (HI%isd-1) - halo_sz + npts = HI%iec - HI%isc + 1 + 2*halo_sz + is = HI%isc - halo_sz ; ie = HI%iec + halo_sz + + if ((US%RL2_T2_to_Pa == 1.0) .and. (US%R_to_kg_m3 == 1.0)) then + 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_HI_1d: EOS%form_of_EOS is not valid.") + end select + elseif (present(spv_ref)) then ! This is the same as above, but with some extra work to rescale variables. + do i=is,ie ; pres(i) = US%RL2_T2_to_Pa * pressure(i) ; enddo + spv_reference = US%kg_m3_to_R*spv_ref + select case (EOS%form_of_EOS) + case (EOS_LINEAR) + call calculate_spec_vol_linear(T, S, pres, specvol, start, npts, & + EOS%rho_T0_S0, EOS%drho_dT, EOS%drho_dS, spv_reference) + case (EOS_UNESCO) + call calculate_spec_vol_unesco(T, S, pres, specvol, start, npts, spv_reference) + case (EOS_WRIGHT) + call calculate_spec_vol_wright(T, S, pres, specvol, start, npts, spv_reference) + case (EOS_TEOS10) + call calculate_spec_vol_teos10(T, S, pres, specvol, start, npts, spv_reference) + case (EOS_NEMO) + call calculate_density_nemo(T, S, pres, rho, start, npts) + specvol = 1.0 / rho - spv_reference + case default + call MOM_error(FATAL, "calculate_spec_vol_HI_1d: EOS%form_of_EOS is not valid.") + end select + else ! There is rescaling of variables, but spv_ref is not present. Passing a 0 value of spv_ref + ! changes answers at roundoff for some equations of state, like Wright and UNESCO. + do i=is,ie ; pres(i) = US%RL2_T2_to_Pa * pressure(i) ; enddo + select case (EOS%form_of_EOS) + case (EOS_LINEAR) + call calculate_spec_vol_linear(T, S, pres, specvol, start, npts, & + EOS%rho_T0_S0, EOS%drho_dT, EOS%drho_dS) + case (EOS_UNESCO) + call calculate_spec_vol_unesco(T, S, pres, specvol, start, npts) + case (EOS_WRIGHT) + call calculate_spec_vol_wright(T, S, pres, specvol, start, npts) + case (EOS_TEOS10) + call calculate_spec_vol_teos10(T, S, pres, specvol, start, npts) + case (EOS_NEMO) + call calculate_density_nemo(T, S, pres, rho, start, npts) + do i=is,ie ; specvol(i) = 1.0 / rho(i) ; enddo + case default + call MOM_error(FATAL, "calculate_spec_vol_HI_1d: EOS%form_of_EOS is not valid.") + end select + endif + + if (US%R_to_kg_m3 /= 1.0) then ; do i=is,ie + specvol(i) = US%R_to_kg_m3 * specvol(i) + enddo ; endif + +end subroutine calculate_spec_vol_HI_1d !> Calls the appropriate subroutine to calculate the freezing point for scalar inputs. subroutine calculate_TFreeze_scalar(S, pressure, T_fr, EOS, pres_scale) @@ -515,6 +702,78 @@ subroutine calculate_density_derivs_array(T, S, pressure, drho_dT, drho_dS, star end subroutine calculate_density_derivs_array + +!> Calls the appropriate subroutine to calculate density derivatives for 1-D array inputs. +subroutine calculate_density_derivs_HI_1d(T, S, pressure, drho_dT, drho_dS, HI, EOS, US, halo) + type(hor_index_type), intent(in) :: HI !< The horizontal index structure + real, dimension(HI%isd:HI%ied), intent(in) :: T !< Potential temperature referenced to the surface [degC] + real, dimension(HI%isd:HI%ied), intent(in) :: S !< Salinity [ppt] + real, dimension(HI%isd:HI%ied), intent(in) :: pressure !< Pressure [R L2 T-2 ~> Pa] + real, dimension(HI%isd:HI%ied), intent(inout) :: drho_dT !< The partial derivative of density with potential + !! temperature [R degC-1 ~> kg m-3 degC-1] + real, dimension(HI%isd:HI%ied), intent(inout) :: drho_dS !< The partial derivative of density with salinity + !! [R degC-1 ~> kg m-3 ppt-1] + type(EOS_type), pointer :: EOS !< Equation of state structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + integer, optional, intent(in) :: halo !< The halo size to work on; missing is equivalent to 0. + + ! Local variables + real, dimension(HI%isd:HI%ied) :: pres ! Pressure converted to [Pa] + real :: rho_reference ! rho_ref converted to [kg m-3] + integer :: i, is, ie, start, npts, halo_sz + + if (.not.associated(EOS)) call MOM_error(FATAL, & + "calculate_density_derivs called with an unassociated EOS_type EOS.") + + halo_sz = 0 ; if (present(halo)) halo_sz = halo + + start = HI%isc - (HI%isd-1) - halo_sz + npts = HI%iec - HI%isc + 1 + 2*halo_sz + is = HI%isc - halo_sz ; ie = HI%iec + halo_sz + + if (US%RL2_T2_to_Pa == 1.0) then + 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) + case (EOS_UNESCO) + call calculate_density_derivs_unesco(T, S, pressure, drho_dT, drho_dS, start, npts) + case (EOS_WRIGHT) + call calculate_density_derivs_wright(T, S, pressure, drho_dT, drho_dS, start, npts) + case (EOS_TEOS10) + call calculate_density_derivs_teos10(T, S, pressure, drho_dT, drho_dS, start, npts) + case (EOS_NEMO) + call calculate_density_derivs_nemo(T, S, pressure, drho_dT, drho_dS, start, npts) + case default + call MOM_error(FATAL, "calculate_density_derivs_HI_1d: EOS%form_of_EOS is not valid.") + end select + else + do i=is,ie ; pres(i) = US%RL2_T2_to_Pa * pressure(i) ; enddo + select case (EOS%form_of_EOS) + case (EOS_LINEAR) + call calculate_density_derivs_linear(T, S, pres, 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, pres, drho_dT, drho_dS, start, npts) + case (EOS_WRIGHT) + call calculate_density_derivs_wright(T, S, pres, drho_dT, drho_dS, start, npts) + case (EOS_TEOS10) + call calculate_density_derivs_teos10(T, S, pres, drho_dT, drho_dS, start, npts) + case (EOS_NEMO) + call calculate_density_derivs_nemo(T, S, pres, drho_dT, drho_dS, start, npts) + case default + call MOM_error(FATAL, "calculate_density_derivs_HI_1d: EOS%form_of_EOS is not valid.") + end select + endif + + if (US%kg_m3_to_R /= 1.0) then ; do i=is,ie + drho_dT(i) = US%kg_m3_to_R * drho_dT(i) + drho_dS(i) = US%kg_m3_to_R * drho_dS(i) + enddo ; endif + +end subroutine calculate_density_derivs_HI_1d + + !> 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, scale, pres_scale) @@ -620,8 +879,7 @@ subroutine calculate_density_second_derivs_array(T, S, pressure, drho_dS_dS, drh end select endif - if (present(scale)) then ; if (scale /= 1.0) then - ; do j=start,start+npts-1 + if (present(scale)) then ; if (scale /= 1.0) then ; do j=start,start+npts-1 drho_dS_dS(j) = scale * drho_dS_dS(j) drho_dS_dT(j) = scale * drho_dS_dT(j) drho_dT_dT(j) = scale * drho_dT_dT(j) @@ -699,7 +957,7 @@ subroutine calculate_density_second_derivs_scalar(T, S, pressure, drho_dS_dS, dr end subroutine calculate_density_second_derivs_scalar !> Calls the appropriate subroutine to calculate specific volume derivatives for an array. -subroutine calculate_specific_vol_derivs(T, S, pressure, dSV_dT, dSV_dS, start, npts, EOS, scale, pres_scale) +subroutine calculate_spec_vol_derivs_array(T, S, pressure, dSV_dT, dSV_dS, start, npts, EOS, scale, pres_scale) real, dimension(:), intent(in) :: T !< Potential temperature referenced to the surface [degC] real, dimension(:), intent(in) :: S !< Salinity [ppt] real, dimension(:), intent(in) :: pressure !< Pressure [Pa] @@ -715,48 +973,173 @@ subroutine calculate_specific_vol_derivs(T, S, pressure, dSV_dT, dSV_dS, start, real, optional, intent(in) :: pres_scale !< A multiplicative factor to convert pressure into Pa. ! Local variables - real, dimension(size(T)) :: dRho_dT, dRho_dS, rho + real, dimension(size(T)) :: press ! Pressure converted to [Pa] + real, dimension(size(T)) :: rho ! In situ density [kg m-3] + real, dimension(size(T)) :: dRho_dT ! Derivative of density with temperature [kg m-3 degC-1] + real, dimension(size(T)) :: dRho_dS ! Derivative of density with salinity [kg m-3 ppt-1] real :: p_scale ! A factor to convert pressure to units of Pa. integer :: j if (.not.associated(EOS)) call MOM_error(FATAL, & - "calculate_density_derivs called with an unassociated EOS_type EOS.") + "calculate_spec_vol_derivs_array called with an unassociated EOS_type EOS.") p_scale = 1.0 ; if (present(pres_scale)) p_scale = pres_scale - select case (EOS%form_of_EOS) - case (EOS_LINEAR) - call calculate_specvol_derivs_linear(T, S, pressure, dSV_dT, dSV_dS, start, & - npts, EOS%Rho_T0_S0, EOS%dRho_dT, EOS%dRho_dS) - case (EOS_UNESCO) - call calculate_density_unesco(T, S, pressure, rho, start, npts) - call calculate_density_derivs_unesco(T, S, pressure, drho_dT, drho_dS, start, npts) - do j=start,start+npts-1 - dSV_dT(j) = -dRho_DT(j)/(rho(j)**2) - dSV_dS(j) = -dRho_DS(j)/(rho(j)**2) - enddo - case (EOS_WRIGHT) - call calculate_specvol_derivs_wright(T, S, pressure, dSV_dT, dSV_dS, start, npts) - case (EOS_TEOS10) - call calculate_specvol_derivs_teos10(T, S, pressure, dSV_dT, dSV_dS, start, npts) - case (EOS_NEMO) - call calculate_density_nemo(T, S, pressure, rho, start, npts) - call calculate_density_derivs_nemo(T, S, pressure, drho_dT, drho_dS, start, npts) - do j=start,start+npts-1 - dSV_dT(j) = -dRho_DT(j)/(rho(j)**2) - dSV_dS(j) = -dRho_DS(j)/(rho(j)**2) - enddo - case default - call MOM_error(FATAL, "calculate_density_derivs: EOS%form_of_EOS is not valid.") - end select + if (p_scale == 1.0) then + select case (EOS%form_of_EOS) + case (EOS_LINEAR) + call calculate_specvol_derivs_linear(T, S, pressure, dSV_dT, dSV_dS, start, & + npts, EOS%Rho_T0_S0, EOS%dRho_dT, EOS%dRho_dS) + case (EOS_UNESCO) + call calculate_density_unesco(T, S, pressure, rho, start, npts) + call calculate_density_derivs_unesco(T, S, pressure, drho_dT, drho_dS, start, npts) + do j=start,start+npts-1 + dSV_dT(j) = -dRho_DT(j)/(rho(j)**2) + dSV_dS(j) = -dRho_DS(j)/(rho(j)**2) + enddo + case (EOS_WRIGHT) + call calculate_specvol_derivs_wright(T, S, pressure, dSV_dT, dSV_dS, start, npts) + case (EOS_TEOS10) + call calculate_specvol_derivs_teos10(T, S, pressure, dSV_dT, dSV_dS, start, npts) + case (EOS_NEMO) + call calculate_density_nemo(T, S, pressure, rho, start, npts) + call calculate_density_derivs_nemo(T, S, pressure, drho_dT, drho_dS, start, npts) + do j=start,start+npts-1 + dSV_dT(j) = -dRho_DT(j)/(rho(j)**2) + dSV_dS(j) = -dRho_DS(j)/(rho(j)**2) + enddo + case default + call MOM_error(FATAL, "calculate_spec_vol_derivs_array: EOS%form_of_EOS is not valid.") + end select + else + do j=start,start+npts-1 ; press(j) = p_scale * pressure(j) ; enddo + select case (EOS%form_of_EOS) + case (EOS_LINEAR) + call calculate_specvol_derivs_linear(T, S, press, dSV_dT, dSV_dS, start, & + npts, EOS%Rho_T0_S0, EOS%dRho_dT, EOS%dRho_dS) + case (EOS_UNESCO) + call calculate_density_unesco(T, S, press, rho, start, npts) + call calculate_density_derivs_unesco(T, S, press, drho_dT, drho_dS, start, npts) + do j=start,start+npts-1 + dSV_dT(j) = -dRho_DT(j)/(rho(j)**2) + dSV_dS(j) = -dRho_DS(j)/(rho(j)**2) + enddo + case (EOS_WRIGHT) + call calculate_specvol_derivs_wright(T, S, press, dSV_dT, dSV_dS, start, npts) + case (EOS_TEOS10) + call calculate_specvol_derivs_teos10(T, S, press, dSV_dT, dSV_dS, start, npts) + case (EOS_NEMO) + call calculate_density_nemo(T, S, pressure, rho, start, npts) + call calculate_density_derivs_nemo(T, S, press, drho_dT, drho_dS, start, npts) + do j=start,start+npts-1 + dSV_dT(j) = -dRho_DT(j)/(rho(j)**2) + dSV_dS(j) = -dRho_DS(j)/(rho(j)**2) + enddo + case default + call MOM_error(FATAL, "calculate_spec_vol_derivs_array: EOS%form_of_EOS is not valid.") + end select + endif if (present(scale)) then ; if (scale /= 1.0) then ; do j=start,start+npts-1 dSV_dT(j) = scale * dSV_dT(j) dSV_dS(j) = scale * dSV_dS(j) enddo ; endif ; endif +end subroutine calculate_spec_vol_derivs_array + +!> Calls the appropriate subroutine to calculate specific volume derivatives for an array. +subroutine calculate_spec_vol_derivs_HI_1d(T, S, pressure, dSV_dT, dSV_dS, HI, EOS, US, halo) + type(hor_index_type), intent(in) :: HI !< The horizontal index structure + real, dimension(HI%isd:HI%ied), intent(in) :: T !< Potential temperature referenced to the surface [degC] + real, dimension(HI%isd:HI%ied), intent(in) :: S !< Salinity [ppt] + real, dimension(HI%isd:HI%ied), intent(in) :: pressure !< Pressure [R L2 T-2 ~> Pa] + real, dimension(HI%isd:HI%ied), intent(inout) :: dSV_dT !< The partial derivative of specific volume with potential + !! temperature [R-1 degC-1 ~> m3 kg-1 degC-1] + real, dimension(HI%isd:HI%ied), intent(inout) :: dSV_dS !< The partial derivative of specific volume with salinity + !! [R-1 ppt-1 ~> m3 kg-1 ppt-1]. + type(EOS_type), pointer :: EOS !< Equation of state structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + integer, optional, intent(in) :: halo !< The halo size to work on; missing is equivalent to 0. + + ! Local variables + real, dimension(HI%isd:HI%ied) :: rho ! In situ density [kg m-3] + real, dimension(HI%isd:HI%ied) :: dRho_dT ! Derivative of density with temperature [kg m-3 degC-1] + real, dimension(HI%isd:HI%ied) :: dRho_dS ! Derivative of density with salinity [kg m-3 ppt-1] + real, dimension(HI%isd:HI%ied) :: press ! Pressure converted to [Pa] + real :: rho_reference ! rho_ref converted to [kg m-3] + integer :: i, is, ie, start, npts, halo_sz + + if (.not.associated(EOS)) call MOM_error(FATAL, & + "calculate_spec_vol_derivs_HI_1d called with an unassociated EOS_type EOS.") + + halo_sz = 0 ; if (present(halo)) halo_sz = halo + + start = HI%isc - (HI%isd-1) - halo_sz + npts = HI%iec - HI%isc + 1 + 2*halo_sz + is = HI%isc - halo_sz ; ie = HI%iec + halo_sz + + if (US%RL2_T2_to_Pa == 1.0) then + select case (EOS%form_of_EOS) + case (EOS_LINEAR) + call calculate_specvol_derivs_linear(T, S, pressure, dSV_dT, dSV_dS, start, & + npts, EOS%Rho_T0_S0, EOS%dRho_dT, EOS%dRho_dS) + case (EOS_UNESCO) + call calculate_density_unesco(T, S, pressure, rho, start, npts) + call calculate_density_derivs_unesco(T, S, pressure, drho_dT, drho_dS, start, npts) + do i=is,ie + dSV_dT(i) = -dRho_DT(i)/(rho(i)**2) + dSV_dS(i) = -dRho_DS(i)/(rho(i)**2) + enddo + case (EOS_WRIGHT) + call calculate_specvol_derivs_wright(T, S, pressure, dSV_dT, dSV_dS, start, npts) + case (EOS_TEOS10) + call calculate_specvol_derivs_teos10(T, S, pressure, dSV_dT, dSV_dS, start, npts) + case (EOS_NEMO) + call calculate_density_nemo(T, S, pressure, rho, start, npts) + call calculate_density_derivs_nemo(T, S, pressure, drho_dT, drho_dS, start, npts) + do i=is,ie + dSV_dT(i) = -dRho_DT(i)/(rho(i)**2) + dSV_dS(i) = -dRho_DS(i)/(rho(i)**2) + enddo + case default + call MOM_error(FATAL, "calculate_spec_vol_derivs_HI_1d: EOS%form_of_EOS is not valid.") + end select + else + do i=is,ie ; press(i) = US%RL2_T2_to_Pa * pressure(i) ; enddo + select case (EOS%form_of_EOS) + case (EOS_LINEAR) + call calculate_specvol_derivs_linear(T, S, press, dSV_dT, dSV_dS, start, & + npts, EOS%Rho_T0_S0, EOS%dRho_dT, EOS%dRho_dS) + case (EOS_UNESCO) + call calculate_density_unesco(T, S, press, rho, start, npts) + call calculate_density_derivs_unesco(T, S, press, drho_dT, drho_dS, start, npts) + do i=is,ie + dSV_dT(i) = -dRho_DT(i)/(rho(i)**2) + dSV_dS(i) = -dRho_DS(i)/(rho(i)**2) + enddo + case (EOS_WRIGHT) + call calculate_specvol_derivs_wright(T, S, press, dSV_dT, dSV_dS, start, npts) + case (EOS_TEOS10) + call calculate_specvol_derivs_teos10(T, S, press, dSV_dT, dSV_dS, start, npts) + case (EOS_NEMO) + call calculate_density_nemo(T, S, pressure, rho, start, npts) + call calculate_density_derivs_nemo(T, S, press, drho_dT, drho_dS, start, npts) + do i=is,ie + dSV_dT(i) = -dRho_DT(i)/(rho(i)**2) + dSV_dS(i) = -dRho_DS(i)/(rho(i)**2) + enddo + case default + call MOM_error(FATAL, "calculate_spec_vol_derivs_HI_1d: EOS%form_of_EOS is not valid.") + end select + endif + + if (US%R_to_kg_m3 /= 1.0) then ; do i=is,ie + drho_dT(i) = US%R_to_kg_m3 * drho_dT(i) + drho_dS(i) = US%R_to_kg_m3 * drho_dS(i) + enddo ; endif + +end subroutine calculate_spec_vol_derivs_HI_1d -end subroutine calculate_specific_vol_derivs !> Calls the appropriate subroutine to calculate the density and compressibility for 1-D array inputs. subroutine calculate_compress_array(T, S, pressure, rho, drho_dp, start, npts, EOS) @@ -791,15 +1174,15 @@ subroutine calculate_compress_array(T, S, pressure, rho, drho_dp, start, npts, E end subroutine calculate_compress_array -!> Calculate density and compressibility for a scalar. This just promotes the scalar to an array with a singleton -!! dimension and calls calculate_compress_array +!> Calculate density and compressibility for a scalar. This just promotes the scalar to an array +!! with a singleton dimension and calls calculate_compress_array subroutine calculate_compress_scalar(T, S, pressure, rho, drho_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) - real, intent(out) :: rho !< In situ density in kg m-3. + real, intent(in) :: T !< Potential temperature referenced to the surface [degC] + real, intent(in) :: S !< Salinity [ppt] + real, intent(in) :: pressure !< Pressure [Pa] + real, intent(out) :: rho !< In situ density [kg m-3] real, intent(out) :: drho_dp !< The partial derivative of density with pressure - !! (also the inverse of the square of sound speed) in s2 m-2. + !! (also the inverse of the square of sound speed) [s2 m-2]. type(EOS_type), pointer :: EOS !< Equation of state structure real, dimension(1) :: Ta, Sa, pa, rhoa, drho_dpa @@ -820,7 +1203,7 @@ end subroutine calculate_compress_scalar !! 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, & - bathyP, dP_tiny, useMassWghtInterp, SV_scale, pres_scale) + bathyP, dP_tiny, useMassWghtInterp, US) type(hor_index_type), intent(in) :: HI !< The horizontal index structure real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & intent(in) :: T !< Potential temperature referenced to the surface [degC] @@ -857,13 +1240,12 @@ subroutine int_specific_vol_dp(T, S, p_t, p_b, alpha_ref, HI, EOS, & !! the same units as p_t [R L2 T-2 ~> Pa] or [Pa] logical, optional, intent(in) :: useMassWghtInterp !< If true, uses mass weighting !! to interpolate T/S for top and bottom integrals. - real, optional, intent(in) :: SV_scale !< A multiplicative factor by which to scale specific - !! volume from m3 kg-1 to the desired units [kg m-3 R-1 ~> 1] - real, optional, intent(in) :: pres_scale !< A multiplicative factor to convert pressure - !! into Pa [Pa T2 R-1 L-2 ~> 1]. + type(unit_scale_type), optional, intent(in) :: US !< A dimensional unit scaling type ! Local variables - real :: rho_scale ! A scaling factor for densities from kg m-3 to R [R m3 kg-1 ~> 1] + real :: pres_scale ! A unit conversion factor from the rescaled units of pressure to Pa [Pa T2 R-1 L-2 ~> 1] + real :: SV_scale ! A multiplicative factor by which to scale specific + ! volume from m3 kg-1 to the desired units [kg m-3 R-1 ~> 1] if (.not.associated(EOS)) call MOM_error(FATAL, & "int_specific_vol_dp called with an unassociated EOS_type EOS.") @@ -871,14 +1253,13 @@ subroutine int_specific_vol_dp(T, S, p_t, p_b, alpha_ref, HI, 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, & - bathyP, dP_tiny, useMassWghtInterp, SV_scale, pres_scale) + bathyP, dP_tiny, useMassWghtInterp, US) else ; select case (EOS%form_of_EOS) case (EOS_LINEAR) - if (present(SV_scale)) then - rho_scale = 1.0 / SV_scale - call int_spec_vol_dp_linear(T, S, p_t, p_b, alpha_ref, HI, rho_scale*EOS%Rho_T0_S0, & - rho_scale*EOS%dRho_dT, rho_scale*EOS%dRho_dS, dza, intp_dza, & - intx_dza, inty_dza, halo_size, & + if (present(US)) then + call int_spec_vol_dp_linear(T, S, p_t, p_b, alpha_ref, HI, US%kg_m3_to_R*EOS%Rho_T0_S0, & + US%kg_m3_to_R*EOS%dRho_dT, US%kg_m3_to_R*EOS%dRho_dS, dza, & + intp_dza, intx_dza, inty_dza, halo_size, & bathyP, dP_tiny, useMassWghtInterp) else call int_spec_vol_dp_linear(T, S, p_t, p_b, alpha_ref, HI, EOS%Rho_T0_S0, & @@ -887,13 +1268,18 @@ subroutine int_specific_vol_dp(T, S, p_t, p_b, alpha_ref, HI, EOS, & bathyP, dP_tiny, useMassWghtInterp) endif 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, & - bathyP, dP_tiny, useMassWghtInterp, SV_scale, pres_scale) + if (present(US)) then + call int_spec_vol_dp_wright(T, S, p_t, p_b, alpha_ref, HI, dza, intp_dza, intx_dza, & + inty_dza, halo_size, bathyP, dP_tiny, useMassWghtInterp, & + SV_scale=US%R_to_kg_m3, pres_scale=US%RL2_T2_to_Pa) + else + call int_spec_vol_dp_wright(T, S, p_t, p_b, alpha_ref, HI, dza, intp_dza, intx_dza, & + inty_dza, halo_size, bathyP, dP_tiny, useMassWghtInterp) + endif 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, & - bathyP, dP_tiny, useMassWghtInterp, SV_scale, pres_scale) + bathyP, dP_tiny, useMassWghtInterp, US) end select ; endif end subroutine int_specific_vol_dp @@ -902,7 +1288,7 @@ end subroutine int_specific_vol_dp !! pressure anomalies across layers, which are required for calculating the !! 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, bathyT, dz_neglect, useMassWghtInterp, rho_scale, pres_scale) + intz_dpa, intx_dpa, inty_dpa, bathyT, dz_neglect, useMassWghtInterp, US) type(hor_index_type), intent(in) :: HII !< Ocean horizontal index structures for the input arrays type(hor_index_type), intent(in) :: HIO !< Ocean horizontal index structures for the output arrays real, dimension(HII%isd:HII%ied,HII%jsd:HII%jed), & @@ -942,21 +1328,23 @@ subroutine int_density_dz(T, S, z_t, z_b, rho_ref, rho_0, G_e, HII, HIO, EOS, dp real, optional, intent(in) :: dz_neglect !< A miniscule thickness change [Z ~> m]. logical, optional, intent(in) :: useMassWghtInterp !< If true, uses mass weighting to !! interpolate T/S for top and bottom integrals. - real, optional, intent(in) :: rho_scale !< A multiplicative factor by which to scale density - !! from kg m-3 to the desired units [R m3 kg-1 ~> 1] - real, optional, intent(in) :: pres_scale !< A multiplicative factor to convert pressure - !! into Pa [R L2 T-2 Pa-1 ~> 1]. + type(unit_scale_type), optional, intent(in) :: US !< A dimensional unit scaling type + + ! Local variables + real :: rho_scale ! A multiplicative factor by which to scale density from kg m-3 to the + ! desired units [R m3 kg-1 ~> 1]. + real :: pres_scale ! A multiplicative factor to convert pressure into Pa [Pa T2 R-1 L-2 ~> 1]. 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, bathyT, dz_neglect, useMassWghtInterp, & - rho_scale, pres_scale) + intz_dpa, intx_dpa, inty_dpa, bathyT, dz_neglect, useMassWghtInterp, US) else ; select case (EOS%form_of_EOS) case (EOS_LINEAR) - if (present(rho_scale)) then + rho_scale = 1.0 ; if (present(US)) rho_scale = US%kg_m3_to_R + if (rho_scale /= 1.0) then call int_density_dz_linear(T, S, z_t, z_b, rho_ref, rho_0, G_e, HII, HIO, & rho_scale*EOS%Rho_T0_S0, rho_scale*EOS%dRho_dT, rho_scale*EOS%dRho_dS, & dpa, intz_dpa, intx_dpa, inty_dpa, bathyT, dz_neglect, useMassWghtInterp) @@ -966,13 +1354,20 @@ subroutine int_density_dz(T, S, z_t, z_b, rho_ref, rho_0, G_e, HII, HIO, EOS, dp dpa, intz_dpa, intx_dpa, inty_dpa, bathyT, dz_neglect, useMassWghtInterp) endif 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, & - bathyT, dz_neglect, useMassWghtInterp, rho_scale, pres_scale) + rho_scale = 1.0 ; if (present(US)) rho_scale = US%kg_m3_to_R + pres_scale = 1.0 ; if (present(US)) pres_scale = US%RL2_T2_to_Pa + if ((rho_scale /= 1.0) .or. (pres_scale /= 1.0)) then + 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, bathyT, & + dz_neglect, useMassWghtInterp, rho_scale, pres_scale) + else + 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, bathyT, & + dz_neglect, useMassWghtInterp) + endif 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, bathyT, dz_neglect, useMassWghtInterp, & - rho_scale, pres_scale) + intz_dpa, intx_dpa, inty_dpa, bathyT, dz_neglect, useMassWghtInterp, US) end select ; endif end subroutine int_density_dz @@ -1166,7 +1561,7 @@ end subroutine EOS_use_linear !! 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, & - bathyT, dz_neglect, useMassWghtInterp, rho_scale, pres_scale) + bathyT, dz_neglect, useMassWghtInterp, US) 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), & @@ -1187,18 +1582,18 @@ subroutine int_density_dz_generic(T, S, z_t, z_b, rho_ref, rho_0, G_e, HII, HIO, !! [L2 Z-1 T-2 ~> m s-2] or [m2 Z-1 s-2 ~> m s-2]. type(EOS_type), pointer :: EOS !< Equation of state structure real, dimension(HIO%isd:HIO%ied,HIO%jsd:HIO%jed), & - intent(inout) :: dpa !< The change in the pressure anomaly + intent(inout) :: dpa !< The change in the pressure anomaly !! across the layer [R L2 T-2 ~> Pa] or [Pa]. real, dimension(HIO%isd:HIO%ied,HIO%jsd:HIO%jed), & - optional, intent(inout) :: intz_dpa !< The integral through the thickness of the + optional, intent(inout) :: intz_dpa !< The integral through the thickness of the !! layer of the pressure anomaly relative to the !! anomaly at the top of the layer [R L2 Z T-2 ~> Pa m]. real, dimension(HIO%IsdB:HIO%IedB,HIO%jsd:HIO%jed), & - optional, intent(inout) :: intx_dpa !< The integral in x of the difference between + optional, intent(inout) :: 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 [R L2 T-2 ~> Pa]. real, dimension(HIO%isd:HIO%ied,HIO%JsdB:HIO%JedB), & - optional, intent(inout) :: inty_dpa !< The integral in y of the difference between + optional, intent(inout) :: 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 [R L2 T-2 ~> Pa]. real, dimension(HII%isd:HII%ied,HII%jsd:HII%jed), & @@ -1206,10 +1601,8 @@ subroutine int_density_dz_generic(T, S, z_t, z_b, rho_ref, rho_0, G_e, HII, HIO, real, optional, intent(in) :: dz_neglect !< A miniscule thickness change [Z ~> m]. logical, optional, intent(in) :: useMassWghtInterp !< If true, uses mass weighting to !! interpolate T/S for top and bottom integrals. - real, optional, intent(in) :: rho_scale !< A multiplicative factor by which to scale density - !! from kg m-3 to the desired units [R m3 kg-1 ~> 1] - real, optional, intent(in) :: pres_scale !< A multiplicative factor to convert pressure - !! into Pa [Pa T2 R-1 L-2 ~> 1]. + type(unit_scale_type), optional, intent(in) :: US !< A dimensional unit scaling type + ! Local variables real :: T5(5), S5(5) ! Temperatures and salinities at five quadrature points [degC] and [ppt] real :: p5(5) ! Pressures at five quadrature points, never rescaled from Pa [Pa] @@ -1219,6 +1612,7 @@ subroutine int_density_dz_generic(T, S, z_t, z_b, rho_ref, rho_0, G_e, HII, HIO, real, parameter :: C1_90 = 1.0/90.0 ! Rational constants. real :: GxRho ! The gravitational acceleration times density and unit conversion factors [Pa Z-1 ~> kg m-2 s-2] real :: I_Rho ! The inverse of the Boussinesq density [R-1 ~> m3 kg-1] or [m3 kg-1] + real :: rho_scale ! A scaling factor for densities from kg m-3 to R [R m3 kg-1 ~> 1] real :: rho_ref_mks ! The reference density in MKS units, never rescaled from kg m-3 [kg m-3] real :: dz ! The layer thickness [Z ~> m]. real :: hWght ! A pressure-thickness below topography [Z ~> m]. @@ -1243,8 +1637,9 @@ subroutine int_density_dz_generic(T, S, z_t, z_b, rho_ref, rho_0, G_e, HII, HIO, is = HIO%isc + ioff ; ie = HIO%iec + ioff js = HIO%jsc + joff ; je = HIO%jec + joff - GxRho = G_e * rho_0 ; if (present(pres_scale)) GxRho = pres_scale * G_e * rho_0 - rho_ref_mks = rho_ref ; if (present(rho_scale)) rho_ref_mks = rho_ref / rho_scale + rho_scale = 1.0 ; if (present(US)) rho_scale = US%kg_m3_to_R + GxRho = G_e * rho_0 ; if (present(US)) GxRho = US%RL2_T2_to_Pa * G_e * rho_0 + rho_ref_mks = rho_ref ; if (present(US)) rho_ref_mks = rho_ref * US%R_to_kg_m3 I_Rho = 1.0 / rho_0 do_massWeight = .false. @@ -1262,7 +1657,11 @@ subroutine int_density_dz_generic(T, S, z_t, z_b, rho_ref, rho_0, G_e, HII, HIO, 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, rho_ref_mks, scale=rho_scale) + if (rho_scale /= 1.0) then + call calculate_density(T5, S5, p5, r5, 1, 5, EOS, rho_ref_mks, scale=rho_scale) + else + call calculate_density(T5, S5, p5, r5, 1, 5, EOS, rho_ref_mks) + endif ! 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)) @@ -1304,7 +1703,11 @@ subroutine int_density_dz_generic(T, S, z_t, z_b, rho_ref, rho_0, G_e, HII, HIO, 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, rho_ref_mks, scale=rho_scale) + if (rho_scale /= 1.0) then + call calculate_density(T5, S5, p5, r5, 1, 5, EOS, rho_ref_mks, scale=rho_scale) + else + call calculate_density(T5, S5, p5, r5, 1, 5, EOS, rho_ref_mks) + endif ! 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))) @@ -1346,7 +1749,11 @@ subroutine int_density_dz_generic(T, S, z_t, z_b, rho_ref, rho_0, G_e, HII, HIO, 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, rho_ref_mks, scale=rho_scale) + if (rho_scale /= 1.0) then + call calculate_density(T5, S5, p5, r5, 1, 5, EOS, rho_ref_mks, scale=rho_scale) + else + call calculate_density(T5, S5, p5, r5, 1, 5, EOS, rho_ref_mks) + endif ! 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))) @@ -1363,8 +1770,7 @@ end subroutine int_density_dz_generic !! T and S are linear profiles. subroutine int_density_dz_generic_plm (T_t, T_b, S_t, S_b, z_t, z_b, rho_ref, & rho_0, G_e, dz_subroundoff, bathyT, HII, HIO, EOS, dpa, & - intz_dpa, intx_dpa, inty_dpa, & - useMassWghtInterp, rho_scale, pres_scale) + intz_dpa, intx_dpa, inty_dpa, useMassWghtInterp, US) type(hor_index_type), intent(in) :: HII !< Ocean horizontal index structures for the input arrays type(hor_index_type), intent(in) :: HIO !< Ocean horizontal index structures for the output arrays real, dimension(HII%isd:HII%ied,HII%jsd:HII%jed), & @@ -1404,10 +1810,8 @@ subroutine int_density_dz_generic_plm (T_t, T_b, S_t, S_b, z_t, z_b, rho_ref, & !! divided by the y grid spacing [R L2 T-2 ~> Pa]. logical, optional, intent(in) :: useMassWghtInterp !< If true, uses mass weighting to !! interpolate T/S for top and bottom integrals. - real, optional, intent(in) :: rho_scale !< A multiplicative factor by which to scale density - !! from kg m-3 to the desired units [R m3 kg-1 ~> 1] - real, optional, intent(in) :: pres_scale !< A multiplicative factor to convert pressure - !! into Pa [Pa T2 R-1 L-2 ~> 1]. + type(unit_scale_type), optional, intent(in) :: US !< A dimensional unit scaling type + ! 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 @@ -1439,6 +1843,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 ! A rational constant [nondim]. real :: GxRho ! The gravitational acceleration times density and unit conversion factors [Pa Z-1 ~> kg m-2 s-2] real :: I_Rho ! The inverse of the Boussinesq density [R-1 ~> m3 kg-1] or [m3 kg-1] + real :: rho_scale ! A scaling factor for densities from kg m-3 to R [R m3 kg-1 ~> 1] real :: rho_ref_mks ! The reference density in MKS units, never rescaled from kg m-3 [kg m-3] real :: dz(HIO%iscB:HIO%iecB+1) ! Layer thicknesses at tracer points [Z ~> m]. real :: dz_x(5,HIO%iscB:HIO%iecB) ! Layer thicknesses along an x-line of subrid locations [Z ~> m]. @@ -1459,8 +1864,9 @@ subroutine int_density_dz_generic_plm (T_t, T_b, S_t, S_b, z_t, z_b, rho_ref, & Isq = HIO%IscB ; Ieq = HIO%IecB ; Jsq = HIO%JscB ; Jeq = HIO%JecB - GxRho = G_e * rho_0 ; if (present(pres_scale)) GxRho = pres_scale * G_e * rho_0 - rho_ref_mks = rho_ref ; if (present(rho_scale)) rho_ref_mks = rho_ref / rho_scale + rho_scale = 1.0 ; if (present(US)) rho_scale = US%kg_m3_to_R + GxRho = G_e * rho_0 ; if (present(US)) GxRho = US%RL2_T2_to_Pa * G_e * rho_0 + rho_ref_mks = rho_ref ; if (present(US)) rho_ref_mks = rho_ref * US%R_to_kg_m3 I_Rho = 1.0 / rho_0 massWeightToggle = 0. if (present(useMassWghtInterp)) then @@ -1486,7 +1892,11 @@ 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, rho_ref_mks, scale=rho_scale) + if (rho_scale /= 1.0) then + call calculate_density_array(T5, S5, p5, r5, 1, (ieq-isq+2)*5, EOS, rho_ref_mks, scale=rho_scale) + else + call calculate_density_array(T5, S5, p5, r5, 1, (ieq-isq+2)*5, EOS, rho_ref_mks) + endif do i=isq,ieq+1 ; iin = i+ioff ! Use Bode's rule to estimate the pressure anomaly change. @@ -1566,7 +1976,11 @@ subroutine int_density_dz_generic_plm (T_t, T_b, S_t, S_b, z_t, z_b, rho_ref, & enddo enddo - call calculate_density(T15, S15, p15, r15, 1, 15*(ieq-isq+1), EOS, rho_ref_mks, scale=rho_scale) + if (rho_scale /= 1.0) then + call calculate_density(T15, S15, p15, r15, 1, 15*(ieq-isq+1), EOS, rho_ref_mks, scale=rho_scale) + else + call calculate_density(T15, S15, p15, r15, 1, 15*(ieq-isq+1), EOS, rho_ref_mks) + endif do I=Isq,Ieq ; iin = i+ioff intz(1) = dpa(i,j) ; intz(5) = dpa(i+1,j) @@ -1645,8 +2059,13 @@ subroutine int_density_dz_generic_plm (T_t, T_b, S_t, S_b, z_t, z_b, rho_ref, & enddo 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, rho_ref_mks, scale=rho_scale) + if (rho_scale /= 1.0) then + 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, rho_ref_mks, scale=rho_scale) + else + 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, rho_ref_mks) + endif do i=HIO%isc,HIO%iec ; iin = i+ioff intz(1) = dpa(i,j) ; intz(5) = dpa(i,j+1) @@ -1784,9 +2203,9 @@ end function frac_dp_at_pos ! ========================================================================== !> Compute pressure gradient force integrals for the case where T and S !! are parabolic profiles -subroutine int_density_dz_generic_ppm (T, T_t, T_b, S, S_t, S_b, & - z_t, z_b, rho_ref, rho_0, G_e, HII, HIO, & - EOS, dpa, intz_dpa, intx_dpa, inty_dpa, rho_scale, pres_scale) +subroutine int_density_dz_generic_ppm(T, T_t, T_b, S, S_t, S_b, & + z_t, z_b, rho_ref, rho_0, G_e, HII, HIO, & + EOS, dpa, intz_dpa, intx_dpa, inty_dpa, US) type(hor_index_type), intent(in) :: HII !< Ocean horizontal index structures for the input arrays type(hor_index_type), intent(in) :: HIO !< Ocean horizontal index structures for the output arrays @@ -1826,10 +2245,7 @@ subroutine int_density_dz_generic_ppm (T, T_t, T_b, S, S_t, S_b, & optional, intent(inout) :: 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 [Pa]. - real, optional, intent(in) :: rho_scale !< A multiplicative factor by which to scale density - !! from kg m-3 to the desired units [R m3 kg-1 ~> 1] - real, optional, intent(in) :: pres_scale !< A multiplicative factor to convert pressure - !! into Pa [Pa T2 R-1 L-2 ~> 1]. + type(unit_scale_type), optional, intent(in) :: US !< A dimensional unit scaling type ! This subroutine calculates (by numerical quadrature) integrals of ! pressure anomalies across layers, which are required for calculating the @@ -1855,6 +2271,7 @@ subroutine int_density_dz_generic_ppm (T, T_t, T_b, S, S_t, S_b, & real, parameter :: C1_90 = 1.0/90.0 ! Rational constants. real :: GxRho ! The gravitational acceleration times density and unit conversion factors [Pa Z-1 ~> kg m-2 s-2] real :: I_Rho ! The inverse of the Boussinesq density [R-1 ~> m3 kg-1] or [m3 kg-1] + real :: rho_scale ! A scaling factor for densities from kg m-3 to R [R m3 kg-1 ~> 1] real :: rho_ref_mks ! The reference density in MKS units, never rescaled from kg m-3 [kg m-3] real :: dz real :: weight_t, weight_b @@ -1881,8 +2298,9 @@ subroutine int_density_dz_generic_ppm (T, T_t, T_b, S, S_t, S_b, & is = HIO%isc + ioff ; ie = HIO%iec + ioff js = HIO%jsc + joff ; je = HIO%jec + joff - GxRho = G_e * rho_0 ; if (present(pres_scale)) GxRho = pres_scale * G_e * rho_0 - rho_ref_mks = rho_ref ; if (present(rho_scale)) rho_ref_mks = rho_ref / rho_scale + rho_scale = 1.0 ; if (present(US)) rho_scale = US%kg_m3_to_R + GxRho = G_e * rho_0 ; if (present(US)) GxRho = US%RL2_T2_to_Pa * G_e * rho_0 + rho_ref_mks = rho_ref ; if (present(US)) rho_ref_mks = rho_ref * US%R_to_kg_m3 I_Rho = 1.0 / rho_0 ! ============================= @@ -1910,7 +2328,11 @@ subroutine int_density_dz_generic_ppm (T, T_t, T_b, S, S_t, S_b, & T5(n) = t0 + t1 * xi + t2 * xi**2 enddo - call calculate_density(T5, S5, p5, r5, 1, 5, EOS, rho_ref_mks, scale=rho_scale) + if (rho_scale /= 1.0) then + call calculate_density(T5, S5, p5, r5, 1, 5, EOS, rho_ref_mks, scale=rho_scale) + else + call calculate_density(T5, S5, p5, r5, 1, 5, EOS, rho_ref_mks) + endif ! 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)) @@ -1969,7 +2391,11 @@ subroutine int_density_dz_generic_ppm (T, T_t, T_b, S, S_t, S_b, & T5(n) = t0 + t1 * xi + t2 * xi**2 enddo - call calculate_density(T5, S5, p5, r5, 1, 5, EOS, rho_ref_mks, scale=rho_scale) + if (rho_scale /= 1.0) then + call calculate_density(T5, S5, p5, r5, 1, 5, EOS, rho_ref_mks, scale=rho_scale) + else + call calculate_density(T5, S5, p5, r5, 1, 5, EOS, rho_ref_mks) + endif ! 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)) + & @@ -2016,7 +2442,11 @@ 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, rho_ref_mks, scale=rho_scale ) + if (rho_scale /= 1.0) then + call calculate_density( T_node, S_node, p_node, r_node, 1, 9, EOS, rho_ref_mks, scale=rho_scale ) + else + call calculate_density( T_node, S_node, p_node, r_node, 1, 9, EOS, rho_ref_mks) + endif r_node = r_node - rho_ref call compute_integral_quadratic( x, y, r_node, intx_dpa(i-ioff,j-joff) ) @@ -2231,9 +2661,9 @@ end subroutine evaluate_shape_quadratic !! 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, & - bathyP, dP_neglect, useMassWghtInterp, SV_scale, pres_scale) +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, & + bathyP, dP_neglect, useMassWghtInterp, US) 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 !< Potential temperature of the layer [degC]. @@ -2271,10 +2701,7 @@ subroutine int_spec_vol_dp_generic(T, S, p_t, p_b, alpha_ref, HI, EOS, & !! the same units as p_t [R L2 T-2 ~> Pa] or [Pa] logical, optional, intent(in) :: useMassWghtInterp !< If true, uses mass weighting !! to interpolate T/S for top and bottom integrals. - real, optional, intent(in) :: SV_scale !< A multiplicative factor by which to scale specific - !! volume from m3 kg-1 to the desired units [kg m-3 R-1 ~> 1] - real, optional, intent(in) :: pres_scale !< A multiplicative factor to convert pressure - !! into Pa [Pa T2 R-1 L-2 ~> 1]. + type(unit_scale_type), optional, intent(in) :: US !< A dimensional unit scaling type ! This subroutine calculates analytical and nearly-analytical integrals in ! pressure across layers of geopotential anomalies, which are required for @@ -2301,6 +2728,8 @@ subroutine int_spec_vol_dp_generic(T, S, p_t, p_b, alpha_ref, HI, EOS, & real :: intp(5) ! The integrals of specific volume with pressure at the ! 5 sub-column locations [L2 T-2 ~> m2 s-2]. real :: RL2_T2_to_Pa ! A unit conversion factor from the rescaled units of pressure to Pa [Pa T2 R-1 L-2 ~> 1] + real :: SV_scale ! A multiplicative factor by which to scale specific + ! volume from m3 kg-1 to the desired units [kg m-3 R-1 ~> 1] 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 @@ -2311,8 +2740,9 @@ 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 - RL2_T2_to_Pa = 1.0 ; if (present(pres_scale)) RL2_T2_to_Pa = pres_scale - alpha_ref_mks = alpha_ref ; if (present(SV_scale)) alpha_ref_mks = alpha_ref / SV_scale + SV_scale = 1.0 ; if (present(US)) SV_scale = US%R_to_kg_m3 + RL2_T2_to_Pa = 1.0 ; if (present(US)) RL2_T2_to_Pa = US%RL2_T2_to_Pa + alpha_ref_mks = alpha_ref ; if (present(US)) alpha_ref_mks = alpha_ref * US%kg_m3_to_R do_massWeight = .false. if (present(useMassWghtInterp)) then ; if (useMassWghtInterp) then @@ -2329,7 +2759,12 @@ subroutine int_spec_vol_dp_generic(T, S, p_t, p_b, alpha_ref, HI, EOS, & T5(n) = T(i,j) ; S5(n) = S(i,j) p5(n) = RL2_T2_to_Pa * (p_b(i,j) - 0.25*real(n-1)*dp) enddo - call calculate_spec_vol(T5, S5, p5, a5, 1, 5, EOS, alpha_ref_mks, scale=SV_scale) + + if (SV_scale /= 1.0) then + call calculate_spec_vol(T5, S5, p5, a5, 1, 5, EOS, alpha_ref_mks, scale=SV_scale) + else + call calculate_spec_vol(T5, S5, p5, a5, 1, 5, EOS, alpha_ref_mks) + endif ! 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)) @@ -2373,7 +2808,11 @@ subroutine int_spec_vol_dp_generic(T, S, p_t, p_b, alpha_ref, HI, EOS, & do n=2,5 T5(n) = T5(1) ; S5(n) = S5(1) ; p5(n) = p5(n-1) - RL2_T2_to_Pa * 0.25*dp enddo - call calculate_spec_vol(T5, S5, p5, a5, 1, 5, EOS, alpha_ref_mks, scale=SV_scale) + if (SV_scale /= 1.0) then + call calculate_spec_vol(T5, S5, p5, a5, 1, 5, EOS, alpha_ref_mks, scale=SV_scale) + else + call calculate_spec_vol(T5, S5, p5, a5, 1, 5, EOS, alpha_ref_mks) + endif ! 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)) + & @@ -2416,7 +2855,11 @@ subroutine int_spec_vol_dp_generic(T, S, p_t, p_b, alpha_ref, HI, EOS, & do n=2,5 T5(n) = T5(1) ; S5(n) = S5(1) ; p5(n) = RL2_T2_to_Pa * (p5(n-1) - 0.25*dp) enddo - call calculate_spec_vol(T5, S5, p5, a5, 1, 5, EOS, alpha_ref_mks, scale=SV_scale) + if (SV_scale /= 1.0) then + call calculate_spec_vol(T5, S5, p5, a5, 1, 5, EOS, alpha_ref_mks, scale=SV_scale) + else + call calculate_spec_vol(T5, S5, p5, a5, 1, 5, EOS, alpha_ref_mks) + endif ! 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)) + & @@ -2435,7 +2878,7 @@ end subroutine int_spec_vol_dp_generic !! 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, SV_scale, pres_scale) + intp_dza, intx_dza, inty_dza, useMassWghtInterp, US) 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 [degC]. @@ -2476,10 +2919,7 @@ subroutine int_spec_vol_dp_generic_plm(T_t, T_b, S_t, S_b, p_t, p_b, alpha_ref, !! by the y grid spacing [L2 T-2 ~> m2 s-2] or [m2 s-2]. logical, optional, intent(in) :: useMassWghtInterp !< If true, uses mass weighting !! to interpolate T/S for top and bottom integrals. - real, optional, intent(in) :: SV_scale !< A multiplicative factor by which to scale specific - !! volume from m3 kg-1 to the desired units [kg m-3 R-1 ~> 1] - real, optional, intent(in) :: pres_scale !< A multiplicative factor to convert pressure - !! into Pa [Pa T2 R-1 L-2 ~> 1]. + type(unit_scale_type), optional, intent(in) :: US !< A dimensional unit scaling type ! This subroutine calculates analytical and nearly-analytical integrals in ! pressure across layers of geopotential anomalies, which are required for @@ -2513,6 +2953,8 @@ subroutine int_spec_vol_dp_generic_plm(T_t, T_b, S_t, S_b, p_t, p_b, alpha_ref, real :: intp(5) ! The integrals of specific volume with pressure at the ! 5 sub-column locations [L2 T-2 ~> m2 s-2]. real :: RL2_T2_to_Pa ! A unit conversion factor from the rescaled units of pressure to Pa [Pa T2 R-1 L-2 ~> 1] + real :: SV_scale ! A multiplicative factor by which to scale specific + ! volume from m3 kg-1 to the desired units [kg m-3 R-1 ~> 1] 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 @@ -2522,9 +2964,9 @@ subroutine int_spec_vol_dp_generic_plm(T_t, T_b, S_t, S_b, p_t, p_b, alpha_ref, do_massWeight = .false. if (present(useMassWghtInterp)) do_massWeight = useMassWghtInterp - RL2_T2_to_Pa = 1.0 ; if (present(pres_scale)) RL2_T2_to_Pa = pres_scale - alpha_ref_mks = alpha_ref ; if (present(SV_scale)) alpha_ref_mks = alpha_ref / SV_scale - + SV_scale = 1.0 ; if (present(US)) SV_scale = US%R_to_kg_m3 + RL2_T2_to_Pa = 1.0 ; if (present(US)) RL2_T2_to_Pa = US%RL2_T2_to_Pa + alpha_ref_mks = alpha_ref ; if (present(US)) alpha_ref_mks = alpha_ref * US%kg_m3_to_R do n = 1, 5 ! Note that these are reversed from int_density_dz. wt_t(n) = 0.25 * real(n-1) @@ -2541,7 +2983,11 @@ subroutine int_spec_vol_dp_generic_plm(T_t, T_b, S_t, S_b, p_t, p_b, alpha_ref, 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_mks, scale=SV_scale) + if (SV_scale /= 1.0) then + call calculate_spec_vol(T5, S5, p5, a5, 1, 5, EOS, alpha_ref_mks, scale=SV_scale) + else + call calculate_spec_vol(T5, S5, p5, a5, 1, 5, EOS, alpha_ref_mks) + endif ! 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)) @@ -2598,7 +3044,11 @@ subroutine int_spec_vol_dp_generic_plm(T_t, T_b, S_t, S_b, p_t, p_b, alpha_ref, enddo enddo - call calculate_spec_vol(T15, S15, p15, a15, 1, 15, EOS, alpha_ref_mks, scale=SV_scale) + if (SV_scale /= 1.0) then + call calculate_spec_vol(T15, S15, p15, a15, 1, 15, EOS, alpha_ref_mks, scale=SV_scale) + else + call calculate_spec_vol(T15, S15, p15, a15, 1, 15, EOS, alpha_ref_mks) + endif intp(1) = dza(i,j) ; intp(5) = dza(i+1,j) do m=2,4 @@ -2657,7 +3107,11 @@ subroutine int_spec_vol_dp_generic_plm(T_t, T_b, S_t, S_b, p_t, p_b, alpha_ref, enddo enddo - call calculate_spec_vol(T15, S15, p15, a15, 1, 15, EOS, alpha_ref_mks, scale=SV_scale) + if (SV_scale /= 1.0) then + call calculate_spec_vol(T15, S15, p15, a15, 1, 15, EOS, alpha_ref_mks, scale=SV_scale) + else + call calculate_spec_vol(T15, S15, p15, a15, 1, 15, EOS, alpha_ref_mks) + endif intp(1) = dza(i,j) ; intp(5) = dza(i,j+1) do m=2,4 From 2fc1c2e5a1d6c8e23c023065cff3973adb80b98b Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 10 Apr 2020 21:42:22 -0400 Subject: [PATCH 164/316] Use new HI_1d forms of calculate_density calls Revised numerous calls to calculate_density and calculate_density_derivs to use the new form with domain extents indicated by a hor_index_type argument. Internal density variables were also rescaled in a few cases. All answers are bitwise identical. --- src/core/MOM.F90 | 25 ++++++----- src/core/MOM_PressureForce_Montgomery.F90 | 3 -- src/core/MOM_PressureForce_blocked_AFV.F90 | 12 ++--- src/core/MOM_isopycnal_slopes.F90 | 10 ++--- src/ice_shelf/MOM_ice_shelf.F90 | 44 +++++++++---------- .../MOM_state_initialization.F90 | 5 +-- .../vertical/MOM_bulk_mixed_layer.F90 | 21 ++++----- .../vertical/MOM_diabatic_aux.F90 | 11 +++-- .../vertical/MOM_diabatic_driver.F90 | 11 +++-- .../vertical/MOM_entrain_diffusive.F90 | 23 +++++----- .../vertical/MOM_full_convection.F90 | 12 ++--- .../vertical/MOM_geothermal.F90 | 12 ++--- .../vertical/MOM_internal_tide_input.F90 | 4 +- .../vertical/MOM_regularize_layers.F90 | 10 ++--- .../vertical/MOM_set_diffusivity.F90 | 28 ++++++------ .../vertical/MOM_set_viscosity.F90 | 10 ++--- 16 files changed, 113 insertions(+), 128 deletions(-) diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index fa952e1d92..0dc34fa670 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -2685,11 +2685,11 @@ subroutine adjust_ssh_for_p_atm(tv, G, GV, US, ssh, p_atm, use_EOS) type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real, dimension(SZI_(G),SZJ_(G)), intent(inout) :: ssh !< time mean surface height [m] - real, dimension(:,:), optional, pointer :: p_atm !< atmospheric pressure [R L2 T-2 ~> Pa] + real, dimension(:,:), optional, pointer :: p_atm !< Ocean surface pressure [R L2 T-2 ~> Pa] logical, optional, intent(in) :: use_EOS !< If true, calculate the density for !! the SSH correction using the equation of state. - real :: Rho_conv ! The density used to convert surface pressure to + real :: Rho_conv(SZI_(G)) ! The density used to convert surface pressure to ! a corrected effective SSH [R ~> kg m-3]. real :: IgR0 ! The SSH conversion factor from R L2 T-2 to m [m T2 R-1 L-2 ~> m Pa-1]. logical :: calc_rho @@ -2699,18 +2699,21 @@ subroutine adjust_ssh_for_p_atm(tv, G, GV, US, ssh, p_atm, use_EOS) 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 - do j=js,je ; do i=is,ie + ! Correct the output sea surface height for the contribution from the ice pressure. + do j=js,je if (calc_rho) then - call calculate_density(tv%T(i,j,1), tv%S(i,j,1), p_atm(i,j)/2.0, Rho_conv, & - tv%eqn_of_state, scale=US%kg_m3_to_R, pres_scale=US%RL2_T2_to_Pa) + call calculate_density(tv%T(:,j,1), tv%S(:,j,1), 0.5*p_atm(:,j), Rho_conv, G%HI, & + tv%eqn_of_state, US) + do i=is,ie + IgR0 = US%Z_to_m / (Rho_conv(i) * GV%g_Earth) + ssh(i,j) = ssh(i,j) + p_atm(i,j) * IgR0 + enddo else - Rho_conv = GV%Rho0 + do i=is,ie + ssh(i,j) = ssh(i,j) + p_atm(i,j) * (US%Z_to_m / (GV%Rho0 * GV%g_Earth)) + enddo endif - IgR0 = US%Z_to_m / (Rho_conv * GV%g_Earth) - ssh(i,j) = ssh(i,j) + p_atm(i,j) * IgR0 - enddo ; enddo + enddo endif ; endif end subroutine adjust_ssh_for_p_atm diff --git a/src/core/MOM_PressureForce_Montgomery.F90 b/src/core/MOM_PressureForce_Montgomery.F90 index 1665e28def..3aeffb762f 100644 --- a/src/core/MOM_PressureForce_Montgomery.F90 +++ b/src/core/MOM_PressureForce_Montgomery.F90 @@ -766,9 +766,6 @@ subroutine Set_pbce_nonBouss(p, tv, G, GV, US, GFS_scale, pbce, alpha_star) S_int(i) = 0.5*(tv%S(i,j,k)+tv%S(i,j,k+1)) enddo call calculate_density(T_int, S_int, p(:,j,k+1), rho_in_situ, G%HI, tv%eqn_of_state, US, halo=1) -! call calculate_density_derivs(T_int, S_int, p(:,j,k+1), dR_dT, dR_dS, & -! Isq, Ieq-Isq+2, tv%eqn_of_state, & -! scale=US%kg_m3_to_R, pres_scale=US%RL2_T2_to_Pa) call calculate_density_derivs(T_int, S_int, p(:,j,k+1), dR_dT, dR_dS, G%HI, & tv%eqn_of_state, US, halo=1) do i=Isq,Ieq+1 diff --git a/src/core/MOM_PressureForce_blocked_AFV.F90 b/src/core/MOM_PressureForce_blocked_AFV.F90 index c532e17001..38d27b3563 100644 --- a/src/core/MOM_PressureForce_blocked_AFV.F90 +++ b/src/core/MOM_PressureForce_blocked_AFV.F90 @@ -301,8 +301,8 @@ subroutine PressureForce_blk_AFV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, 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, scale=US%kg_m3_to_R, pres_scale=US%RL2_T2_to_Pa) + call calculate_density(tv_tmp%T(:,j,1), tv_tmp%S(:,j,1), p(:,j,1), rho_in_situ, G%HI, & + tv%eqn_of_state, US, halo=1) 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)) @@ -586,11 +586,11 @@ subroutine PressureForce_blk_AFV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, !$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, scale=US%kg_m3_to_R, pres_scale=US%RL2_T2_to_Pa) + call calculate_density(tv_tmp%T(:,j,1), tv_tmp%S(:,j,1), p_atm(:,j), rho_in_situ, G%HI, & + tv%eqn_of_state, US, halo=1) 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, scale=US%kg_m3_to_R) + call calculate_density(tv_tmp%T(:,j,1), tv_tmp%S(:,j,1), p0, rho_in_situ, G%HI, & + tv%eqn_of_state, US, halo=1) endif do i=Isq,Ieq+1 dM(i,j) = (CS%GFS_scale - 1.0) * (G_Rho0 * rho_in_situ(i)) * e(i,j,1) diff --git a/src/core/MOM_isopycnal_slopes.F90 b/src/core/MOM_isopycnal_slopes.F90 index e5101d9937..00b5264251 100644 --- a/src/core/MOM_isopycnal_slopes.F90 +++ b/src/core/MOM_isopycnal_slopes.F90 @@ -175,9 +175,8 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, & T_u(I) = 0.25*((T(i,j,k) + T(i+1,j,k)) + (T(i,j,k-1) + T(i+1,j,k-1))) S_u(I) = 0.25*((S(i,j,k) + S(i+1,j,k)) + (S(i,j,k-1) + S(i+1,j,k-1))) enddo - call calculate_density_derivs(T_u, S_u, pres_u, drho_dT_u, & - drho_dS_u, (is-IsdB+1)-1, ie-is+2, tv%eqn_of_state, scale=US%kg_m3_to_R, & - pres_scale=US%RL2_T2_to_Pa) + call calculate_density_derivs(T_u, S_u, pres_u, drho_dT_u, drho_dS_u, (is-IsdB+1)-1, ie-is+2, & + tv%eqn_of_state, scale=US%kg_m3_to_R, pres_scale=US%RL2_T2_to_Pa) endif do I=is-1,ie @@ -262,9 +261,8 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, & T_v(i) = 0.25*((T(i,j,k) + T(i,j+1,k)) + (T(i,j,k-1) + T(i,j+1,k-1))) S_v(i) = 0.25*((S(i,j,k) + S(i,j+1,k)) + (S(i,j,k-1) + S(i,j+1,k-1))) enddo - call calculate_density_derivs(T_v, S_v, pres_v, drho_dT_v, & - drho_dS_v, is, ie-is+1, tv%eqn_of_state, scale=US%kg_m3_to_R, & - pres_scale=US%RL2_T2_to_Pa) + call calculate_density_derivs(T_v, S_v, pres_v, drho_dT_v, drho_dS_v, is, ie-is+1, & + tv%eqn_of_state, scale=US%kg_m3_to_R, pres_scale=US%RL2_T2_to_Pa) endif do i=is,ie if (use_EOS) then diff --git a/src/ice_shelf/MOM_ice_shelf.F90 b/src/ice_shelf/MOM_ice_shelf.F90 index 298fbc4507..858af4e1ea 100644 --- a/src/ice_shelf/MOM_ice_shelf.F90 +++ b/src/ice_shelf/MOM_ice_shelf.F90 @@ -197,27 +197,27 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) !! describe the surface state of the ocean. The !! intent is only inout to allow for halo updates. type(forcing), intent(inout) :: fluxes !< structure containing pointers to any possible - !! thermodynamic or mass-flux forcing fields. + !! 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 [s]. - type(ice_shelf_CS), pointer :: CS !< A pointer to the control structure - !! returned by a previous call to - !! initialize_ice_shelf. + real, intent(in) :: time_step !< Length of time over which these fluxes + !! will be applied [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(unit_scale_type), pointer :: US => NULL() ! Pointer to a structure containing - ! various unit conversion factors + ! Local variables + type(ocean_grid_type), pointer :: G => NULL() !< The grid structure used by the ice shelf. + type(unit_scale_type), pointer :: US => NULL() !< Pointer to a structure containing + !! various unit conversion factors type(ice_shelf_state), pointer :: ISS => NULL() !< A structure with elements that describe - !! the ice-shelf state + !! the ice-shelf state real, dimension(SZI_(CS%grid)) :: & - Rhoml, & !< Ocean mixed layer density [kg m-3]. + Rhoml, & !< Ocean mixed layer density [R ~> kg m-3]. dR0_dT, & !< Partial derivative of the mixed layer density - !< with temperature [kg m-3 degC-1]. + !< with temperature [R degC-1 ~> kg m-3 degC-1]. dR0_dS, & !< Partial derivative of the mixed layer density - !< with salinity [kg m-3 ppt-1]. + !< with salinity [R ppt-1 ~> kg m-3 ppt-1]. p_int !< The pressure at the ice-ocean interface [R L2 T-2 ~> Pa]. real, dimension(SZI_(CS%grid),SZJ_(CS%grid)) :: & @@ -235,8 +235,8 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) !! viscosity is linearly increasing [nondim]. (Was 1/8. Why?) real, parameter :: RC = 0.20 ! critical flux Richardson number. real :: I_ZETA_N !< The inverse of ZETA_N [nondim]. - real :: I_LF !< The inverse of the latent Heat of fusion [Q-1 ~> kg J-1]. - real :: I_VK !< The inverse of VK. + real :: I_LF !< The inverse of the latent heat of fusion [Q-1 ~> kg J-1]. + real :: I_VK !< The inverse of the Von Karman constant [nondim]. real :: PR, SC !< The Prandtl number and Schmidt number [nondim]. ! 3 equations formulation variables @@ -263,7 +263,7 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) ! boundary layer salinity times the friction velocity [ppt Z T-1 ~> ppt m s-1] real :: ustar_h ! The friction velocity in the water below the ice shelf [Z T-1 ~> m s-1] real :: Gam_turb ! [nondim] - real :: Gam_mol_t, Gam_mol_s + real :: Gam_mol_t, Gam_mol_s ! Relative coefficients of molecular diffusivites [nondim] real :: RhoCp ! A typical ocean density times the heat capacity of water [Q R ~> J m-3] real :: ln_neut real :: mass_exch ! A mass exchange rate [R Z T-1 ~> kg m-2 s-1] @@ -306,8 +306,8 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) RhoCp = CS%Rho_ocn * CS%Cp !first calculate molecular component - Gam_mol_t = 12.5 * (PR**c2_3) - 6 - Gam_mol_s = 12.5 * (SC**c2_3) - 6 + Gam_mol_t = 12.5 * (PR**c2_3) - 6.0 + Gam_mol_s = 12.5 * (SC**c2_3) - 6.0 ! GMM, zero some fields of the ice shelf structure (ice_shelf_CS) ! these fields are already set to zero during initialization @@ -375,10 +375,10 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) 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, & - Rhoml(:), is, ie-is+1, CS%eqn_of_state, pres_scale=US%RL2_T2_to_Pa) - call calculate_density_derivs(state%sst(:,j), state%sss(:,j), p_int, & - dR0_dT, dR0_dS, is, ie-is+1, CS%eqn_of_state, pres_scale=US%RL2_T2_to_Pa) + call calculate_density(state%sst(:,j), state%sss(:,j), p_int, Rhoml(:), G%HI, & + CS%eqn_of_state, US) + call calculate_density_derivs(state%sst(:,j), state%sss(:,j), p_int, dR0_dT, dR0_dS, G%HI, & + CS%eqn_of_state, US) do i=is,ie if ((state%ocean_mass(i,j) > US%RZ_to_kg_m2*CS%col_mass_melt_threshold) .and. & diff --git a/src/initialization/MOM_state_initialization.F90 b/src/initialization/MOM_state_initialization.F90 index afadae1a1b..95faef5449 100644 --- a/src/initialization/MOM_state_initialization.F90 +++ b/src/initialization/MOM_state_initialization.F90 @@ -2185,7 +2185,7 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, G, GV, US, PF, just_read_param allocate(area_shelf_h(isd:ied,jsd:jed)) allocate(frac_shelf_h(isd:ied,jsd:jed)) - press(:) = tv%p_ref + press(:) = tv%P_Ref ! Convert T&S to Absolute Salinity and Conservative Temperature if using TEOS10 or NEMO call convert_temp_salt_for_TEOS10(temp_z, salt_z, press, G, kd, mask_z, eos) @@ -2399,8 +2399,7 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, G, GV, US, PF, just_read_param if (adjust_temperature .and. .not. useALEremapping) then call determine_temperature(tv%T(is:ie,js:je,:), tv%S(is:ie,js:je,:), & - GV%Rlay(1:nz), tv%p_ref, niter, missing_value, h(is:ie,js:je,:), ks, US, eos) - + GV%Rlay(1:nz), tv%P_Ref, niter, missing_value, h(is:ie,js:je,:), ks, US, eos) endif deallocate(z_in, z_edges_in, temp_z, salt_z, mask_z) diff --git a/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 b/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 index 00686c2bbe..88c9e47ba4 100644 --- a/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 +++ b/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 @@ -291,9 +291,9 @@ subroutine bulkmixedlayer(h_3d, u_3d, v_3d, tv, fluxes, dt, ea, eb, G, GV, US, C Net_salt, & ! The surface salt flux into the ocean over a time step, ppt H. Idecay_len_TKE, & ! The inverse of a turbulence decay length scale [H-1 ~> m-1 or m2 kg-1]. p_ref, & ! Reference pressure for the potential density governing mixed - ! layer dynamics, almost always 0 (or 1e5) Pa. + ! layer dynamics, almost always 0 (or 1e5) [R L2 T-2 ~> Pa]. p_ref_cv, & ! Reference pressure for the potential density which defines - ! the coordinate variable, set to P_Ref [Pa]. + ! the coordinate variable, set to P_Ref [R L2 T-2 ~> Pa]. dR0_dT, & ! Partial derivative of the mixed layer potential density with ! temperature [R degC-1 ~> kg m-3 degC-1]. dRcv_dT, & ! Partial derivative of the coordinate variable potential @@ -376,7 +376,7 @@ subroutine bulkmixedlayer(h_3d, u_3d, v_3d, tv, fluxes, dt, ea, eb, G, GV, US, C Idt_diag = 1.0 / (dt__diag) write_diags = .true. ; if (present(last_call)) write_diags = last_call - p_ref(:) = 0.0 ; p_ref_cv(:) = tv%P_Ref + p_ref(:) = 0.0 ; p_ref_cv(:) = US%kg_m3_to_R*US%m_s_to_L_T**2*tv%P_Ref nsw = CS%nsw @@ -464,17 +464,14 @@ subroutine bulkmixedlayer(h_3d, u_3d, v_3d, tv, fluxes, dt, ea, eb, G, GV, US, C ! Calculate an estimate of the mid-mixed layer pressure [Pa] do i=is,ie ; p_ref(i) = 0.0 ; enddo do k=1,CS%nkml ; do i=is,ie - p_ref(i) = p_ref(i) + 0.5*GV%H_to_Pa*h(i,k) + p_ref(i) = p_ref(i) + 0.5*(GV%H_to_RZ*GV%g_Earth)*h(i,k) enddo ; enddo - call calculate_density_derivs(T(:,1), S(:,1), p_ref, dR0_dT, dR0_dS, & - is, ie-is+1, tv%eqn_of_state, scale=US%kg_m3_to_R) - call calculate_density_derivs(T(:,1), S(:,1), p_ref_cv, dRcv_dT, dRcv_dS, & - is, ie-is+1, tv%eqn_of_state, scale=US%kg_m3_to_R) + call calculate_density_derivs(T(:,1), S(:,1), p_ref, dR0_dT, dR0_dS, G%HI, tv%eqn_of_state, US) + call calculate_density_derivs(T(:,1), S(:,1), p_ref_cv, dRcv_dT, dRcv_dS, G%HI, & + tv%eqn_of_state, US) do k=1,nz - call calculate_density(T(:,k), S(:,k), p_ref, R0(:,k), is, ie-is+1, & - tv%eqn_of_state, scale=US%kg_m3_to_R) - call calculate_density(T(:,k), S(:,k), p_ref_cv, Rcv(:,k), is, & - ie-is+1, tv%eqn_of_state, scale=US%kg_m3_to_R) + call calculate_density(T(:,k), S(:,k), p_ref, R0(:,k), G%HI, tv%eqn_of_state, US) + call calculate_density(T(:,k), S(:,k), p_ref_cv, Rcv(:,k), G%HI, tv%eqn_of_state, US) enddo if (id_clock_EOS>0) call cpu_clock_end(id_clock_EOS) diff --git a/src/parameterizations/vertical/MOM_diabatic_aux.F90 b/src/parameterizations/vertical/MOM_diabatic_aux.F90 index 1d079d451b..32a909fed4 100644 --- a/src/parameterizations/vertical/MOM_diabatic_aux.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_aux.F90 @@ -408,11 +408,11 @@ subroutine insert_brine(h, tv, G, GV, US, fluxes, nkmb, CS, dt, id_brine_lay) real :: dzbr(SZI_(G)) ! Cumulative depth over which brine is distributed [H ~> m to kg m-2] real :: inject_layer(SZI_(G),SZJ_(G)) ! diagnostic - real :: p_ref_cv(SZI_(G)) + real :: p_ref_cv(SZI_(G)) ! The pressure used to calculate the coordinate density [R L2 T-2 ~> Pa] real :: T(SZI_(G),SZK_(G)) real :: S(SZI_(G),SZK_(G)) real :: h_2d(SZI_(G),SZK_(G)) ! A 2-d slice of h with a minimum thickness [H ~> m to kg m-2] - real :: Rcv(SZI_(G),SZK_(G)) + real :: Rcv(SZI_(G),SZK_(G)) ! The coordinate density [R ~> kg m-3] real :: s_new,R_new,t0,scale, cdz integer :: i, j, k, is, ie, js, je, nz, ks @@ -427,7 +427,7 @@ subroutine insert_brine(h, tv, G, GV, US, fluxes, nkmb, CS, dt, id_brine_lay) ! because it is not convergent when resolution becomes very fine. I think that this whole ! subroutine needs to be revisited.- RWH - p_ref_cv(:) = tv%P_ref + p_ref_cv(:) = US%kg_m3_to_R*US%m_s_to_L_T**2*tv%P_Ref brine_dz = 1.0*GV%m_to_H inject_layer(:,:) = nz @@ -447,8 +447,7 @@ subroutine insert_brine(h, tv, G, GV, US, fluxes, nkmb, CS, dt, id_brine_lay) h_2d(i,k) = MAX(h(i,j,k), GV%Angstrom_H) enddo - call calculate_density(T(:,k), S(:,k), p_ref_cv, Rcv(:,k), is, & - ie-is+1, tv%eqn_of_state) + call calculate_density(T(:,k), S(:,k), p_ref_cv, Rcv(:,k), G%HI, tv%eqn_of_state, US) enddo ! First, try to find an interior layer where inserting all the salt @@ -459,7 +458,7 @@ subroutine insert_brine(h, tv, G, GV, US, fluxes, nkmb, CS, dt, id_brine_lay) if ((G%mask2dT(i,j) > 0.0) .and. dzbr(i) < brine_dz .and. salt(i) > 0.) then s_new = S(i,k) + salt(i) / (GV%H_to_RZ * h_2d(i,k)) t0 = T(i,k) - call calculate_density(t0, s_new, tv%P_Ref, R_new, tv%eqn_of_state) + call calculate_density(t0, s_new, tv%P_Ref, R_new, tv%eqn_of_state, scale=US%kg_m3_to_R) if (R_new < 0.5*(Rcv(i,k)+Rcv(i,k+1)) .and. s_new Pa]. logical :: in_boundary(SZI_(G)) ! True if there are no massive layers below, ! where massive is defined as sufficiently thick that @@ -2681,11 +2680,11 @@ subroutine layered_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_e call cpu_clock_begin(id_clock_sponge) ! Layer mode sponge if (CS%bulkmixedlayer .and. associated(tv%eqn_of_state)) then - do i=is,ie ; p_ref_cv(i) = tv%P_Ref ; enddo + do i=is,ie ; p_ref_cv(i) = US%kg_m3_to_R*US%m_s_to_L_T**2*tv%P_Ref ; enddo !$OMP parallel do default(shared) do j=js,je - call calculate_density(tv%T(:,j,1), tv%S(:,j,1), p_ref_cv, Rcv_ml(:,j), & - is, ie-is+1, tv%eqn_of_state, scale=US%kg_m3_to_R) + call calculate_density(tv%T(:,j,1), tv%S(:,j,1), p_ref_cv, Rcv_ml(:,j), G%HI, & + tv%eqn_of_state, US) enddo call apply_sponge(h, dt, G, GV, US, ea, eb, CS%sponge_CSp, Rcv_ml) else diff --git a/src/parameterizations/vertical/MOM_entrain_diffusive.F90 b/src/parameterizations/vertical/MOM_entrain_diffusive.F90 index e5366897e4..fe7fc57cb0 100644 --- a/src/parameterizations/vertical/MOM_entrain_diffusive.F90 +++ b/src/parameterizations/vertical/MOM_entrain_diffusive.F90 @@ -123,7 +123,7 @@ subroutine entrainment_diffusive(h, tv, fluxes, dt, G, GV, US, CS, ea, eb, & htot, & ! The total thickness above or below a layer [H ~> m or kg m-2]. Rcv, & ! Value of the coordinate variable (potential density) ! based on the simulated T and S and P_Ref [R ~> kg m-3]. - pres, & ! Reference pressure (P_Ref) [Pa]. + pres, & ! Reference pressure (P_Ref) [R L2 T-2 ~> Pa]. eakb, & ! The entrainment from above by the layer below the buffer ! layer (i.e. layer kb) [H ~> m or kg m-2]. ea_kbp1, & ! The entrainment from above by layer kb+1 [H ~> m or kg m-2]. @@ -243,7 +243,7 @@ subroutine entrainment_diffusive(h, tv, fluxes, dt, G, GV, US, CS, ea, eb, & correct_density = (CS%correct_density .and. associated(tv%eqn_of_state)) if (correct_density) then - pres(:) = tv%P_Ref + pres(:) = US%kg_m3_to_R*US%m_s_to_L_T**2*tv%P_Ref else pres(:) = 0.0 endif @@ -700,8 +700,7 @@ subroutine entrainment_diffusive(h, tv, fluxes, dt, G, GV, US, CS, ea, eb, & call determine_dSkb(h_bl, Sref, Ent_bl, eakb, is, ie, kmb, G, GV, & .true., dS_kb, dS_anom_lim=dS_anom_lim) do k=nz-1,kb_min,-1 - call calculate_density(tv%T(is:ie,j,k), tv%S(is:ie,j,k), pres(is:ie), & - Rcv(is:ie), 1, ie-is+1, tv%eqn_of_state, scale=US%kg_m3_to_R) + call calculate_density(tv%T(:,j,k), tv%S(:,j,k), pres, Rcv, G%HI, tv%eqn_of_state, US) do i=is,ie if ((k>kb(i)) .and. (F(i,k) > 0.0)) then ! Within a time step, a layer may entrain no more than its @@ -784,9 +783,8 @@ subroutine entrainment_diffusive(h, tv, fluxes, dt, G, GV, US, CS, ea, eb, & enddo else ! not bulkmixedlayer - do k=K2,nz-1 - call calculate_density(tv%T(is:ie,j,k), tv%S(is:ie,j,k), pres(is:ie), & - Rcv(is:ie), 1, ie-is+1, tv%eqn_of_state, scale=US%kg_m3_to_R) + do k=K2,nz-1; + call calculate_density(tv%T(:,j,k), tv%S(:,j,k), pres, Rcv, G%HI, tv%eqn_of_state, US) do i=is,ie ; if (F(i,k) > 0.0) then ! Within a time step, a layer may entrain no more than ! its thickness for correction. This limitation should @@ -851,8 +849,8 @@ subroutine entrainment_diffusive(h, tv, fluxes, dt, G, GV, US, CS, ea, eb, & S_eos(i) = 0.5*(tv%S(i,j,k-1) + tv%S(i,j,k)) endif enddo - call calculate_density_derivs(T_eos, S_eos, pressure, dRho_dT, dRho_dS, is, ie-is+1, & - tv%eqn_of_state, scale=US%kg_m3_to_R, pres_scale=US%RL2_T2_to_Pa) + call calculate_density_derivs(T_eos, S_eos, pressure, dRho_dT, dRho_dS, G%HI, & + tv%eqn_of_state, US) do i=is,ie if ((k>kmb) .and. (k m-1 or m2 kg-1] and [nondim]. Rcv, & ! Value of the coordinate variable (potential density) ! based on the simulated T and S and P_Ref [R ~> kg m-3]. - pres, & ! Reference pressure (P_Ref) [Pa]. + pres, & ! Reference pressure (P_Ref) [R L2 T-2 ~> Pa]. frac_rem, & ! The fraction of the diffusion remaining [nondim]. h_interior ! The interior thickness available for entrainment [H ~> m or kg m-2]. real, dimension(SZI_(G), SZK_(G)) :: & @@ -1084,10 +1082,9 @@ subroutine set_Ent_bl(h, dtKd_int, tv, kb, kmb, do_i, G, GV, US, CS, j, Ent_bl, max_ent = 1.0e4*GV%m_to_H h_neglect = GV%H_subroundoff - do i=is,ie ; pres(i) = tv%P_Ref ; enddo + do i=is,ie ; pres(i) = US%kg_m3_to_R*US%m_s_to_L_T**2*tv%P_Ref ; enddo do k=1,kmb - call calculate_density(tv%T(is:ie,j,k), tv%S(is:ie,j,k), pres(is:ie), & - Rcv(is:ie), 1, ie-is+1, tv%eqn_of_state, scale=US%kg_m3_to_R) + call calculate_density(tv%T(:,j,k), tv%S(:,j,k), pres, Rcv, G%HI, tv%eqn_of_state, US) do i=is,ie h_bl(i,k) = h(i,j,k) + h_neglect Sref(i,k) = Rcv(i) - CS%Rho_sig_off diff --git a/src/parameterizations/vertical/MOM_full_convection.F90 b/src/parameterizations/vertical/MOM_full_convection.F90 index 288fe01484..11baf7c59e 100644 --- a/src/parameterizations/vertical/MOM_full_convection.F90 +++ b/src/parameterizations/vertical/MOM_full_convection.F90 @@ -407,20 +407,20 @@ subroutine smoothed_dRdT_dRdS(h, tv, Kddt, dR_dT, dR_dS, G, GV, US, j, p_surf, h else do i=is,ie ; pres(i) = 0.0 ; enddo endif - call calculate_density_derivs(T_f(:,1), S_f(:,1), pres, dR_dT(:,1), dR_dS(:,1), is-G%isd+1, ie-is+1, & - tv%eqn_of_state, scale=US%kg_m3_to_R, pres_scale=US%RL2_T2_to_Pa) + call calculate_density_derivs(T_f(:,1), S_f(:,1), pres, dR_dT(:,1), dR_dS(:,1), G%HI, & + tv%eqn_of_state, US) do i=is,ie ; pres(i) = pres(i) + h(i,j,1)*(GV%H_to_RZ*GV%g_Earth) ; enddo do K=2,nz do i=is,ie T_EOS(i) = 0.5*(T_f(i,k-1) + T_f(i,k)) S_EOS(i) = 0.5*(S_f(i,k-1) + S_f(i,k)) enddo - call calculate_density_derivs(T_EOS, S_EOS, pres, dR_dT(:,K), dR_dS(:,K), is-G%isd+1, ie-is+1, & - tv%eqn_of_state, scale=US%kg_m3_to_R, pres_scale=US%RL2_T2_to_Pa) + call calculate_density_derivs(T_EOS, S_EOS, pres, dR_dT(:,K), dR_dS(:,K), G%HI, & + tv%eqn_of_state, US) do i=is,ie ; pres(i) = pres(i) + h(i,j,k)*(GV%H_to_RZ*GV%g_Earth) ; enddo enddo - call calculate_density_derivs(T_f(:,nz), S_f(:,nz), pres, dR_dT(:,nz+1), dR_dS(:,nz+1), is-G%isd+1, & - ie-is+1, tv%eqn_of_state, scale=US%kg_m3_to_R, pres_scale=US%RL2_T2_to_Pa) + call calculate_density_derivs(T_f(:,nz), S_f(:,nz), pres, dR_dT(:,nz+1), dR_dS(:,nz+1), G%HI, & + tv%eqn_of_state, US) end subroutine smoothed_dRdT_dRdS diff --git a/src/parameterizations/vertical/MOM_geothermal.F90 b/src/parameterizations/vertical/MOM_geothermal.F90 index e26e126db8..36231cd668 100644 --- a/src/parameterizations/vertical/MOM_geothermal.F90 +++ b/src/parameterizations/vertical/MOM_geothermal.F90 @@ -77,7 +77,7 @@ subroutine geothermal(h, tv, dt, ea, eb, G, GV, US, CS, halo) heat_rem, & ! remaining heat [H degC ~> m degC or kg degC m-2] h_geo_rem, & ! remaining thickness to apply geothermal heating [H ~> m or kg m-2] Rcv_BL, & ! coordinate density in the deepest variable density layer [R ~> kg m-3] - p_ref ! coordiante densities reference pressure [Pa] + p_ref ! coordinate densities reference pressure [R L2 T-2 ~> Pa] real, dimension(2) :: & T2, S2, & ! temp and saln in the present and target layers [degC] and [ppt] @@ -135,7 +135,7 @@ subroutine geothermal(h, tv, dt, ea, eb, G, GV, US, CS, halo) Irho_cp = 1.0 / (GV%H_to_RZ * tv%C_p) Angstrom = GV%Angstrom_H H_neglect = GV%H_subroundoff - p_ref(:) = tv%P_Ref + p_ref(:) = US%kg_m3_to_R*US%m_s_to_L_T**2*tv%P_Ref Idt = 1.0 / dt if (.not.associated(tv%T)) call MOM_error(FATAL, "MOM geothermal: "//& @@ -198,8 +198,8 @@ subroutine geothermal(h, tv, dt, ea, eb, G, GV, US, CS, halo) iej = is-1 ; do i=ie,is,-1 ; if (do_i(i)) then ; iej = i ; exit ; endif ; enddo if (nkmb > 0) then - call calculate_density(tv%T(:,j,nkmb), tv%S(:,j,nkmb), p_Ref(:), & - Rcv_BL(:), isj, iej-isj+1, tv%eqn_of_state, scale=US%kg_m3_to_R) + call calculate_density(tv%T(:,j,nkmb), tv%S(:,j,nkmb), p_Ref(:), Rcv_BL(:), isj, iej-isj+1, & + tv%eqn_of_state, scale=US%kg_m3_to_R, pres_scale=US%RL2_T2_to_Pa) else Rcv_BL(:) = -1.0 endif @@ -248,8 +248,8 @@ subroutine geothermal(h, tv, dt, ea, eb, G, GV, US, CS, halo) Rcv, tv%eqn_of_state, scale=US%kg_m3_to_R) T2(1) = tv%T(i,j,k) ; S2(1) = tv%S(i,j,k) T2(2) = tv%T(i,j,k_tgt) ; S2(2) = tv%S(i,j,k_tgt) - call calculate_density_derivs(T2(:), S2(:), p_Ref(:), & - dRcv_dT_, dRcv_dS_, 1, 2, tv%eqn_of_state, scale=US%kg_m3_to_R) + call calculate_density_derivs(T2(:), S2(:), p_Ref(:), dRcv_dT_, dRcv_dS_, 1, 2, & + tv%eqn_of_state, scale=US%kg_m3_to_R, pres_scale=US%RL2_T2_to_Pa) dRcv_dT = 0.5*(dRcv_dT_(1) + dRcv_dT_(2)) endif diff --git a/src/parameterizations/vertical/MOM_internal_tide_input.F90 b/src/parameterizations/vertical/MOM_internal_tide_input.F90 index 6c366e5ff9..3ba5520117 100644 --- a/src/parameterizations/vertical/MOM_internal_tide_input.F90 +++ b/src/parameterizations/vertical/MOM_internal_tide_input.F90 @@ -209,8 +209,8 @@ subroutine find_N2_bottom(h, tv, T_f, S_f, h2, fluxes, G, GV, US, N2_bot) Temp_Int(i) = 0.5 * (T_f(i,j,k) + T_f(i,j,k-1)) Salin_Int(i) = 0.5 * (S_f(i,j,k) + S_f(i,j,k-1)) enddo - call calculate_density_derivs(Temp_int, Salin_int, pres, dRho_dT(:), dRho_dS(:), & - is, ie-is+1, tv%eqn_of_state, scale=US%kg_m3_to_R, pres_scale=US%RL2_T2_to_Pa) + call calculate_density_derivs(Temp_int, Salin_int, pres, dRho_dT(:), dRho_dS(:), G%HI, & + tv%eqn_of_state, US) do i=is,ie dRho_int(i,K) = max(dRho_dT(i)*(T_f(i,j,k) - T_f(i,j,k-1)) + & dRho_dS(i)*(S_f(i,j,k) - S_f(i,j,k-1)), 0.0) diff --git a/src/parameterizations/vertical/MOM_regularize_layers.F90 b/src/parameterizations/vertical/MOM_regularize_layers.F90 index a4a4723092..7a77a13433 100644 --- a/src/parameterizations/vertical/MOM_regularize_layers.F90 +++ b/src/parameterizations/vertical/MOM_regularize_layers.F90 @@ -179,7 +179,7 @@ subroutine regularize_surface(h, tv, dt, ea, eb, G, GV, US, CS) ! d_ea mean a net gain in mass by a layer from downward motion. real, dimension(SZI_(G)) :: & p_ref_cv, & ! Reference pressure for the potential density which defines - ! the coordinate variable, set to P_Ref [Pa]. + ! the coordinate variable, set to P_Ref [R L2 T-2 ~> Pa]. Rcv_tol, & ! A tolerence, relative to the target density differences ! between layers, for detraining into the interior [nondim]. h_add_tgt, h_add_tot, & @@ -240,7 +240,7 @@ subroutine regularize_surface(h, tv, dt, ea, eb, G, GV, US, CS) I_dtol = 1.0 / max(CS%h_def_tol2 - CS%h_def_tol1, 1e-40) I_dtol34 = 1.0 / max(CS%h_def_tol4 - CS%h_def_tol3, 1e-40) - p_ref_cv(:) = tv%P_Ref + p_ref_cv(:) = US%kg_m3_to_R*US%m_s_to_L_T**2*tv%P_Ref do j=js-1,je+1 ; do i=is-1,ie+1 e(i,j,1) = 0.0 @@ -312,8 +312,7 @@ subroutine regularize_surface(h, tv, dt, ea, eb, G, GV, US, CS) do j=js,je ; if (do_j(j)) then ! call cpu_clock_begin(id_clock_EOS) -! call calculate_density_derivs(T(:,1), S(:,1), p_ref_cv, dRcv_dT, dRcv_dS, & -! is, ie-is+1, tv%eqn_of_state) +! call calculate_density_derivs(T(:,1), S(:,1), p_ref_cv, dRcv_dT, dRcv_dS, G%HI, tv%eqn_of_state, US) ! call cpu_clock_end(id_clock_EOS) do k=1,nz ; do i=is,ie ; d_ea(i,k) = 0.0 ; d_eb(i,k) = 0.0 ; enddo ; enddo @@ -445,8 +444,7 @@ subroutine regularize_surface(h, tv, dt, ea, eb, G, GV, US, CS) if (det_any) then call cpu_clock_begin(id_clock_EOS) do k=1,nkmb - call calculate_density(T_2d(:,k),S_2d(:,k),p_ref_cv,Rcv(:,k), & - is,ie-is+1,tv%eqn_of_state, scale=US%kg_m3_to_R) + call calculate_density(T_2d(:,k), S_2d(:,k), p_ref_cv, Rcv(:,k), G%HI, tv%eqn_of_state, US) enddo call cpu_clock_end(id_clock_EOS) diff --git a/src/parameterizations/vertical/MOM_set_diffusivity.F90 b/src/parameterizations/vertical/MOM_set_diffusivity.F90 index 9c47841748..38f4975a23 100644 --- a/src/parameterizations/vertical/MOM_set_diffusivity.F90 +++ b/src/parameterizations/vertical/MOM_set_diffusivity.F90 @@ -661,11 +661,10 @@ subroutine find_TKE_to_Kd(h, tv, dRho_int, N2_lay, j, dt, G, GV, US, CS, & real, dimension(SZI_(G)) :: & htot, & ! total thickness above or below a layer, or the ! integrated thickness in the BBL [Z ~> m]. - mFkb, & ! total thickness in the mixed and buffer layers - ! times ds_dsp1 [Z ~> m]. - p_ref, & ! array of tv%P_Ref pressures + mFkb, & ! total thickness in the mixed and buffer layers times ds_dsp1 [Z ~> m]. + p_ref, & ! array of tv%P_Ref pressures [R L2 T-2 ~> Pa] Rcv_kmb, & ! coordinate density in the lowest buffer layer [R ~> kg m-3] - p_0 ! An array of 0 pressures + p_0 ! An array of 0 pressures [R L2 T-2 ~> Pa] real :: dh_max ! maximum amount of entrainment a layer could ! undergo before entraining all fluid in the layers @@ -712,13 +711,13 @@ subroutine find_TKE_to_Kd(h, tv, dRho_int, N2_lay, j, dt, G, GV, US, CS, & ! Determine kb - the index of the shallowest active interior layer. if (CS%bulkmixedlayer) then kmb = GV%nk_rho_varies - do i=is,ie ; p_0(i) = 0.0 ; p_ref(i) = tv%P_Ref ; enddo + do i=is,ie ; p_0(i) = 0.0 ; p_ref(i) = US%kg_m3_to_R*US%m_s_to_L_T**2*tv%P_Ref ; enddo do k=1,nz - call calculate_density(tv%T(:,j,k), tv%S(:,j,k), p_0, rho_0(:,k), & - is, ie-is+1, tv%eqn_of_state, scale=US%kg_m3_to_R) + call calculate_density(tv%T(:,j,k), tv%S(:,j,k), p_0, rho_0(:,k), G%HI, & + tv%eqn_of_state, US) enddo - call calculate_density(tv%T(:,j,kmb), tv%S(:,j,kmb), p_ref, Rcv_kmb, & - is, ie-is+1, tv%eqn_of_state, scale=US%kg_m3_to_R) + call calculate_density(tv%T(:,j,kmb), tv%S(:,j,kmb), p_ref, Rcv_kmb, G%HI, & + tv%eqn_of_state, US) kb_min = kmb+1 do i=is,ie @@ -906,8 +905,8 @@ subroutine find_N2(h, tv, T_f, S_f, fluxes, j, G, GV, US, CS, dRho_int, & Temp_Int(i) = 0.5 * (T_f(i,j,k) + T_f(i,j,k-1)) Salin_Int(i) = 0.5 * (S_f(i,j,k) + S_f(i,j,k-1)) enddo - call calculate_density_derivs(Temp_int, Salin_int, pres, dRho_dT(:,K), dRho_dS(:,K), & - is, ie-is+1, tv%eqn_of_state, scale=US%kg_m3_to_R, pres_scale=US%RL2_T2_to_Pa) + call calculate_density_derivs(Temp_int, Salin_int, pres, dRho_dT(:,K), dRho_dS(:,K), G%HI, & + tv%eqn_of_state, US) do i=is,ie dRho_int(i,K) = max(dRho_dT(i,K)*(T_f(i,j,k) - T_f(i,j,k-1)) + & dRho_dS(i,K)*(S_f(i,j,k) - S_f(i,j,k-1)), 0.0) @@ -1794,7 +1793,7 @@ subroutine set_density_ratios(h, tv, kb, G, GV, US, CS, j, ds_dsp1, rho_0) real :: g_R0 ! g_R0 is a rescaled version of g/Rho [L2 Z-1 R-1 T-2 ~> m4 kg-1 s-2] real :: eps, tmp ! nondimensional temproray variables real :: a(SZK_(G)), a_0(SZK_(G)) ! nondimensional temporary variables - real :: p_ref(SZI_(G)) ! an array of tv%P_Ref pressures + real :: p_ref(SZI_(G)) ! an array of tv%P_Ref pressures [R L2 T-2 ~> Pa] real :: Rcv(SZI_(G),SZK_(G)) ! coordinate density in the mixed and buffer layers [R ~> kg m-3] real :: I_Drho ! temporary variable [R-1 ~> m3 kg-1] @@ -1817,10 +1816,9 @@ subroutine set_density_ratios(h, tv, kb, G, GV, US, CS, j, ds_dsp1, rho_0) g_R0 = GV%g_Earth / (GV%Rho0) kmb = GV%nk_rho_varies eps = 0.1 - do i=is,ie ; p_ref(i) = tv%P_Ref ; enddo + do i=is,ie ; p_ref(i) = US%kg_m3_to_R*US%m_s_to_L_T**2*tv%P_Ref ; enddo do k=1,kmb - call calculate_density(tv%T(:,j,k), tv%S(:,j,k), p_ref, Rcv(:,k), & - is, ie-is+1, tv%eqn_of_state, scale=US%kg_m3_to_R) + call calculate_density(tv%T(:,j,k), tv%S(:,j,k), p_ref, Rcv(:,k), G%HI, tv%eqn_of_state, US) enddo do i=is,ie if (kb(i) <= nz-1) then diff --git a/src/parameterizations/vertical/MOM_set_viscosity.F90 b/src/parameterizations/vertical/MOM_set_viscosity.F90 index 41fd8047dc..472c158f69 100644 --- a/src/parameterizations/vertical/MOM_set_viscosity.F90 +++ b/src/parameterizations/vertical/MOM_set_viscosity.F90 @@ -212,7 +212,7 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, symmetrize) real, dimension(SZI_(G),SZJ_(G),max(GV%nk_rho_varies,1)) :: & Rml ! The mixed layer coordinate density [R ~> kg m-3]. real :: p_ref(SZI_(G)) ! The pressure used to calculate the coordinate - ! density [Pa] (usually set to 2e7 Pa = 2000 dbar). + ! density [R L2 T-2 ~> Pa] (usually set to 2e7 Pa = 2000 dbar). real :: D_vel ! The bottom depth at a velocity point [H ~> m or kg m-2]. real :: Dp, Dm ! The depths at the edges of a velocity cell [H ~> m or kg m-2]. @@ -312,11 +312,11 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, symmetrize) ! if (CS%linear_drag) ustar(:) = cdrag_sqrt_Z*CS%drag_bg_vel if ((nkml>0) .and. .not.use_BBL_EOS) then - do i=Isq,Ieq+1 ; p_ref(i) = tv%P_ref ; enddo + do i=Isq,Ieq+1 ; p_ref(i) = US%kg_m3_to_R*US%m_s_to_L_T**2*tv%P_Ref ; enddo !$OMP parallel do default(shared) - do j=Jsq,Jeq+1 ; do k=1,nkmb - call calculate_density(tv%T(:,j,k), tv%S(:,j,k), p_ref, & - Rml(:,j,k), Isq, Ieq-Isq+2, tv%eqn_of_state, scale=US%kg_m3_to_R) + do k=1,nkmb ; do j=Jsq,Jeq+1 + call calculate_density(tv%T(:,j,k), tv%S(:,j,k), p_ref, Rml(:,j,k), G%HI, & + tv%eqn_of_state, US, halo=1) enddo ; enddo endif From 3223eb6bd5abb1eea2f59e29ee7193a13d91ec51 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sat, 11 Apr 2020 07:57:09 -0400 Subject: [PATCH 165/316] +Rescaled the units of tv%P_Ref to [R L2 T-2] Rescaled the units of tv%P_Ref to [R L2 T-2] for expanded dimensional consistency testing. In some cases, other pressure variables were also rescaled and calls to calculate_density are recast into the simpler G%HI forms. All answers are bitwise identical, but the scaled units of an element of a transparent type were rescaled. --- src/core/MOM.F90 | 11 +++++---- src/core/MOM_PressureForce_Montgomery.F90 | 21 ++++++++-------- src/core/MOM_PressureForce_analytic_FV.F90 | 12 +++++----- src/core/MOM_PressureForce_blocked_AFV.F90 | 12 +++++----- src/core/MOM_variables.F90 | 2 +- src/diagnostics/MOM_diagnostics.F90 | 16 ++++++------- .../MOM_coord_initialization.F90 | 6 ++--- .../MOM_state_initialization.F90 | 24 +++++++++---------- .../vertical/MOM_bulk_mixed_layer.F90 | 2 +- .../vertical/MOM_diabatic_aux.F90 | 5 ++-- .../vertical/MOM_diabatic_driver.F90 | 2 +- .../vertical/MOM_entrain_diffusive.F90 | 4 ++-- .../vertical/MOM_geothermal.F90 | 4 ++-- .../vertical/MOM_regularize_layers.F90 | 2 +- .../vertical/MOM_set_diffusivity.F90 | 4 ++-- .../vertical/MOM_set_viscosity.F90 | 2 +- src/tracer/MOM_tracer_hor_diff.F90 | 6 ++--- src/user/DOME_initialization.F90 | 14 +++++++---- src/user/RGC_initialization.F90 | 5 ++-- src/user/user_change_diffusivity.F90 | 8 +++---- 20 files changed, 82 insertions(+), 80 deletions(-) diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index 0dc34fa670..7cc28919f1 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -1805,7 +1805,8 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & endif ! This is here in case these values are used inappropriately. - use_frazil = .false. ; bound_salinity = .false. ; CS%tv%P_Ref = 2.0e7 + use_frazil = .false. ; bound_salinity = .false. + CS%tv%P_Ref = 2.0e7*US%kg_m3_to_R*US%m_s_to_L_T**2 if (use_temperature) then call get_param(param_file, "MOM", "FRAZIL", use_frazil, & "If true, water freezes if it gets too cold, and the "//& @@ -1820,8 +1821,8 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & "drive the salinity negative otherwise.)", default=.false.) call get_param(param_file, "MOM", "MIN_SALINITY", CS%tv%min_salinity, & "The minimum value of salinity when BOUND_SALINITY=True. "//& - "The default is 0.01 for backward compatibility but ideally "//& - "should be 0.", units="PPT", default=0.01, do_not_log=.not.bound_salinity) + "The default is 0.01 for backward compatibility but ideally should be 0.", & + units="PPT", default=0.01, do_not_log=.not.bound_salinity) call get_param(param_file, "MOM", "C_P", CS%tv%C_p, & "The heat capacity of sea water, approximated as a "//& "constant. This is only used if ENABLE_THERMODYNAMICS is "//& @@ -1832,8 +1833,8 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & if (use_EOS) call get_param(param_file, "MOM", "P_REF", CS%tv%P_Ref, & "The pressure that is used for calculating the coordinate "//& "density. (1 Pa = 1e4 dbar, so 2e7 is commonly used.) "//& - "This is only used if USE_EOS and ENABLE_THERMODYNAMICS "//& - "are true.", units="Pa", default=2.0e7) + "This is only used if USE_EOS and ENABLE_THERMODYNAMICS are true.", & + units="Pa", default=2.0e7, scale=US%kg_m3_to_R*US%m_s_to_L_T**2) if (bulkmixedlayer) then call get_param(param_file, "MOM", "NKML", nkml, & diff --git a/src/core/MOM_PressureForce_Montgomery.F90 b/src/core/MOM_PressureForce_Montgomery.F90 index 3aeffb762f..b7291b71b2 100644 --- a/src/core/MOM_PressureForce_Montgomery.F90 +++ b/src/core/MOM_PressureForce_Montgomery.F90 @@ -106,7 +106,7 @@ subroutine PressureForce_Mont_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, pb geopot_bot ! Bottom geopotential relative to time-mean sea level, ! including any tidal contributions [L2 T-2 ~> m2 s-2]. real :: p_ref(SZI_(G)) ! The pressure used to calculate the coordinate - ! density [Pa] (usually 2e7 Pa = 2000 dbar). + ! density [R L2 T-2 ~> Pa] (usually 2e7 Pa = 2000 dbar). real :: rho_in_situ(SZI_(G)) !In-situ density of a layer [R ~> kg m-3]. real :: PFu_bc, PFv_bc ! The pressure gradient force due to along-layer ! compensated density gradients [L T-2 ~> m s-2] @@ -227,8 +227,8 @@ subroutine PressureForce_Mont_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, pb 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, scale=US%kg_m3_to_R) + call calculate_density(tv%T(:,j,nkmb), tv%S(:,j,nkmb), p_ref, Rho_cv_BL(:), G%HI, & + tv%eqn_of_state, US, halo=1) 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) @@ -244,8 +244,8 @@ subroutine PressureForce_Mont_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, pb endif !$OMP parallel do default(shared) private(rho_in_situ) do k=1,nz ; do j=Jsq,Jeq+1 - call calculate_density(tv_tmp%T(:,j,k),tv_tmp%S(:,j,k),p_ref, & - rho_in_situ,Isq,Ieq-Isq+2,tv%eqn_of_state, scale=US%kg_m3_to_R) + call calculate_density(tv_tmp%T(:,j,k), tv_tmp%S(:,j,k), p_ref, rho_in_situ, G%HI, & + tv%eqn_of_state, US, halo=1) do i=Isq,Ieq+1 ; alpha_star(i,j,k) = 1.0 / rho_in_situ(i) ; enddo enddo ; enddo endif ! use_EOS @@ -394,7 +394,7 @@ subroutine PressureForce_Mont_Bouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, pbce, ! forces from astronomical sources and self- ! attraction and loading, in depth units [Z ~> m]. real :: p_ref(SZI_(G)) ! The pressure used to calculate the coordinate - ! density [Pa] (usually 2e7 Pa = 2000 dbar). + ! density [R L2 T-2 ~> Pa] (usually 2e7 Pa = 2000 dbar). real :: I_Rho0 ! 1/Rho0 [R-1 ~> m3 kg-1]. real :: G_Rho0 ! G_Earth / Rho0 [L2 Z-1 T-2 R-1 ~> m4 s-2 kg-1]. real :: PFu_bc, PFv_bc ! The pressure gradient force due to along-layer @@ -482,8 +482,8 @@ subroutine PressureForce_Mont_Bouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, pbce, 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, scale=US%kg_m3_to_R) + call calculate_density(tv%T(:,j,nkmb), tv%S(:,j,nkmb), p_ref, Rho_cv_BL(:), G%HI, & + tv%eqn_of_state, US, halo=1) do k=nkmb+1,nz ; do i=Isq,Ieq+1 if (GV%Rlay(k) < Rho_cv_BL(i)) then @@ -503,8 +503,9 @@ subroutine PressureForce_Mont_Bouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, pbce, ! will come down with a fatal error if there is any compressibility. !$OMP parallel do default(shared) do k=1,nz+1 ; do j=Jsq,Jeq+1 - call calculate_density(tv_tmp%T(:,j,k), tv_tmp%S(:,j,k), p_ref, rho_star(:,j,k), & - Isq, Ieq-Isq+2, tv%eqn_of_state, scale=US%kg_m3_to_R*G_Rho0) + call calculate_density(tv_tmp%T(:,j,k), tv_tmp%S(:,j,k), p_ref, rho_star(:,j,k), G%HI, & + tv%eqn_of_state, US, halo=1) + do i=Isq,Ieq+1 ; rho_star(i,j,k) = G_Rho0*rho_star(i,j,k) ; enddo enddo ; enddo endif ! use_EOS diff --git a/src/core/MOM_PressureForce_analytic_FV.F90 b/src/core/MOM_PressureForce_analytic_FV.F90 index 10842f9e7e..ca6f7ae283 100644 --- a/src/core/MOM_PressureForce_analytic_FV.F90 +++ b/src/core/MOM_PressureForce_analytic_FV.F90 @@ -157,7 +157,7 @@ subroutine PressureForce_AFV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p real, dimension(SZI_(G),SZJB_(G),SZK_(G)) :: & inty_dza ! The change in inty_za through a layer [L2 T-2 ~> m2 s-2]. real :: p_ref(SZI_(G)) ! The pressure used to calculate the coordinate - ! density, [Pa] (usually 2e7 Pa = 2000 dbar). + ! density, [R L2 T-2 ~> 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 [R L2 T-2 ~> Pa]. @@ -227,8 +227,8 @@ subroutine PressureForce_AFV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p 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, scale=US%kg_m3_to_R) + call calculate_density(tv%T(:,j,nkmb), tv%S(:,j,nkmb), p_ref, Rho_cv_BL(:), G%HI, & + tv%eqn_of_state, US, halo=1) 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) @@ -489,7 +489,7 @@ subroutine PressureForce_AFV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_at ! of salinity and temperature within each layer. real :: rho_in_situ(SZI_(G)) ! The in situ density [R ~> kg m-3]. real :: p_ref(SZI_(G)) ! The pressure used to calculate the coordinate - ! density, [Pa] (usually 2e7 Pa = 2000 dbar). + ! density, [R L2 T-2 ~> Pa] (usually 2e7 Pa = 2000 dbar). real :: p0(SZI_(G)) ! An array of zeros to use for pressure [Pa]. real :: h_neglect ! A thickness that is so small it is usually lost ! in roundoff and can be neglected [H ~> m]. @@ -576,8 +576,8 @@ subroutine PressureForce_AFV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_at 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, scale=US%kg_m3_to_R) + call calculate_density(tv%T(:,j,nkmb), tv%S(:,j,nkmb), p_ref, Rho_cv_BL(:), G%HI, & + tv%eqn_of_state, US, halo=1) do k=nkmb+1,nz ; do i=Isq,Ieq+1 if (GV%Rlay(k) < Rho_cv_BL(i)) then diff --git a/src/core/MOM_PressureForce_blocked_AFV.F90 b/src/core/MOM_PressureForce_blocked_AFV.F90 index 38d27b3563..9d1c12f381 100644 --- a/src/core/MOM_PressureForce_blocked_AFV.F90 +++ b/src/core/MOM_PressureForce_blocked_AFV.F90 @@ -155,7 +155,7 @@ subroutine PressureForce_blk_AFV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, real, dimension(SZI_(G),SZJB_(G),SZK_(G)) :: & inty_dza ! The change in inty_za through a layer [L2 T-2 ~> m2 s-2]. real :: p_ref(SZI_(G)) ! The pressure used to calculate the coordinate - ! density [Pa] (usually 2e7 Pa = 2000 dbar). + ! density [R L2 T-2 ~> 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 [Pa]. @@ -223,8 +223,8 @@ subroutine PressureForce_blk_AFV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, 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, scale=US%kg_m3_to_R) + call calculate_density(tv%T(:,j,nkmb), tv%S(:,j,nkmb), p_ref, Rho_cv_BL(:), G%HI, & + tv%eqn_of_state, US, halo=1) 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) @@ -473,7 +473,7 @@ subroutine PressureForce_blk_AFV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, T_t, T_b ! Top and bottom edge temperatures for linear reconstructions within each layer [degC]. real :: rho_in_situ(SZI_(G)) ! The in situ density [R ~> kg m-3]. real :: p_ref(SZI_(G)) ! The pressure used to calculate the coordinate - ! density [Pa] (usually 2e7 Pa = 2000 dbar). + ! density [R L2 T-2 ~> Pa] (usually 2e7 Pa = 2000 dbar). real :: p0(SZI_(G)) ! An array of zeros to use for pressure [Pa]. real :: h_neglect ! A thickness that is so small it is usually lost ! in roundoff and can be neglected [H ~> m or kg m-2]. @@ -563,8 +563,8 @@ subroutine PressureForce_blk_AFV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, 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, scale=US%kg_m3_to_R) + call calculate_density(tv%T(:,j,nkmb), tv%S(:,j,nkmb), p_ref, Rho_cv_BL(:), G%HI, & + tv%eqn_of_state, US, halo=1) do k=nkmb+1,nz ; do i=Isq,Ieq+1 if (GV%Rlay(k) < Rho_cv_BL(i)) then diff --git a/src/core/MOM_variables.F90 b/src/core/MOM_variables.F90 index 09cbd14c60..52991a0278 100644 --- a/src/core/MOM_variables.F90 +++ b/src/core/MOM_variables.F90 @@ -80,7 +80,7 @@ module MOM_variables real, pointer :: S(:,:,:) => NULL() !< Salnity [PSU] or [gSalt/kg], generically [ppt]. type(EOS_type), pointer :: eqn_of_state => NULL() !< Type that indicates the !! equation of state to use. - real :: P_Ref !< The coordinate-density reference pressure [Pa]. + real :: P_Ref !< The coordinate-density reference pressure [R L2 T-2 ~> Pa]. !! This is the pressure used to calculate Rml from !! T and S when eqn_of_state is associated. real :: C_p !< The heat capacity of seawater [Q degC-1 ~> J degC-1 kg-1]. diff --git a/src/diagnostics/MOM_diagnostics.F90 b/src/diagnostics/MOM_diagnostics.F90 index 8c69853f3d..2aa0dee688 100644 --- a/src/diagnostics/MOM_diagnostics.F90 +++ b/src/diagnostics/MOM_diagnostics.F90 @@ -232,7 +232,7 @@ subroutine calculate_diagnostic_fields(u, v, h, uh, vh, tv, ADp, CDp, p_surf, & ! tmp array for surface properties real :: surface_field(SZI_(G),SZJ_(G)) - real :: pressure_1d(SZI_(G)) ! Temporary array for pressure when calling EOS + real :: pressure_1d(SZI_(G)) ! Temporary array for pressure when calling EOS [R L2 T-2 ~> Pa] or [Pa] real :: wt, wt_p real :: f2_h ! Squared Coriolis parameter at to h-points [T-2 ~> s-2] @@ -347,7 +347,7 @@ subroutine calculate_diagnostic_fields(u, v, h, uh, vh, tv, ADp, CDp, p_surf, & do j=js,je if (associated(p_surf)) then ! Pressure loading at top of surface layer [R L2 T-2 ~> Pa] do i=is,ie - pressure_1d(i) = US%RL2_T2_to_Pa * p_surf(i,j) + pressure_1d(i) = p_surf(i,j) enddo else do i=is,ie @@ -356,16 +356,16 @@ subroutine calculate_diagnostic_fields(u, v, h, uh, vh, tv, ADp, CDp, p_surf, & endif do k=1,nz ! Integrate vertically downward for pressure do i=is,ie ! Pressure for EOS at the layer center [Pa] - pressure_1d(i) = pressure_1d(i) + 0.5*GV%H_to_Pa*h(i,j,k) + pressure_1d(i) = pressure_1d(i) + 0.5*(GV%H_to_RZ*GV%g_Earth)*h(i,j,k) enddo ! Store in-situ density [R ~> kg m-3] in work_3d - call calculate_density(tv%T(:,j,k),tv%S(:,j,k), pressure_1d, & - rho_in_situ, is, ie-is+1, tv%eqn_of_state, scale=US%kg_m3_to_R) + call calculate_density(tv%T(:,j,k), tv%S(:,j,k), pressure_1d, rho_in_situ, G%HI, & + tv%eqn_of_state, US) do i=is,ie ! Cell thickness = dz = dp/(g*rho) (meter); store in work_3d work_3d(i,j,k) = (GV%H_to_RZ*h(i,j,k)) / rho_in_situ(i) enddo do i=is,ie ! Pressure for EOS at the bottom interface [Pa] - pressure_1d(i) = pressure_1d(i) + 0.5*GV%H_to_Pa*h(i,j,k) + pressure_1d(i) = pressure_1d(i) + 0.5*(GV%H_to_RZ*GV%g_Earth)*h(i,j,k) enddo enddo ! k enddo ! j @@ -465,8 +465,8 @@ subroutine calculate_diagnostic_fields(u, v, h, uh, vh, tv, ADp, CDp, p_surf, & pressure_1d(:) = tv%P_Ref !$OMP parallel do default(shared) do k=1,nz ; do j=js-1,je+1 - call calculate_density(tv%T(:,j,k), tv%S(:,j,k), pressure_1d, & - Rcv(:,j,k), is-1, ie-is+3, tv%eqn_of_state , scale=US%kg_m3_to_R) + call calculate_density(tv%T(:,j,k), tv%S(:,j,k), pressure_1d, Rcv(:,j,k), G%HI, & + tv%eqn_of_state, US, halo=1) enddo ; enddo else ! Rcv should not be used much in this case, so fill in sensible values. do k=1,nz ; do j=js-1,je+1 ; do i=is-1,ie+1 diff --git a/src/initialization/MOM_coord_initialization.F90 b/src/initialization/MOM_coord_initialization.F90 index 63461df157..d4afa115af 100644 --- a/src/initialization/MOM_coord_initialization.F90 +++ b/src/initialization/MOM_coord_initialization.F90 @@ -89,11 +89,11 @@ subroutine MOM_initialize_coord(GV, US, PF, write_geom, output_dir, tv, max_dept case ("linear") call set_coord_linear(GV%Rlay, GV%g_prime, GV, US, PF) case ("ts_ref") - call set_coord_from_ts_ref(GV%Rlay, GV%g_prime, GV, US, PF, eos, tv%P_Ref) + call set_coord_from_ts_ref(GV%Rlay, GV%g_prime, GV, US, PF, eos, US%RL2_T2_to_Pa*tv%P_Ref) case ("ts_profile") - call set_coord_from_TS_profile(GV%Rlay, GV%g_prime, GV, US, PF, eos, tv%P_Ref) + call set_coord_from_TS_profile(GV%Rlay, GV%g_prime, GV, US, PF, eos, US%RL2_T2_to_Pa*tv%P_Ref) case ("ts_range") - call set_coord_from_TS_range(GV%Rlay, GV%g_prime, GV, US, PF, eos, tv%P_Ref) + call set_coord_from_TS_range(GV%Rlay, GV%g_prime, GV, US, PF, eos, US%RL2_T2_to_Pa*tv%P_Ref) case ("file") call set_coord_from_file(GV%Rlay, GV%g_prime, GV, US, PF) case ("USER") diff --git a/src/initialization/MOM_state_initialization.F90 b/src/initialization/MOM_state_initialization.F90 index 95faef5449..6339211d3e 100644 --- a/src/initialization/MOM_state_initialization.F90 +++ b/src/initialization/MOM_state_initialization.F90 @@ -291,9 +291,9 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, US, PF, dirs, & case ("ISOMIP"); call ISOMIP_initialize_thickness(h, G, GV, US, PF, tv, & just_read_params=just_read) case ("benchmark"); call benchmark_initialize_thickness(h, G, GV, US, PF, & - tv%eqn_of_state, tv%P_Ref, just_read_params=just_read) + tv%eqn_of_state, US%RL2_T2_to_Pa*tv%P_Ref, just_read_params=just_read) case ("Neverland"); call Neverland_initialize_thickness(h, G, GV, US, PF, & - tv%eqn_of_state, tv%P_Ref) + tv%eqn_of_state, US%RL2_T2_to_Pa*tv%P_Ref) case ("search"); call initialize_thickness_search case ("circle_obcs"); call circle_obcs_initialize_thickness(h, G, GV, PF, & just_read_params=just_read) @@ -348,11 +348,11 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, US, PF, dirs, & ! " \t baroclinic_zone - an analytic baroclinic zone. \n"//& select case (trim(config)) case ("fit"); call initialize_temp_salt_fit(tv%T, tv%S, G, GV, US, PF, & - eos, tv%P_Ref, just_read_params=just_read) + eos, US%RL2_T2_to_Pa*tv%P_Ref, just_read_params=just_read) case ("file"); call initialize_temp_salt_from_file(tv%T, tv%S, G, & PF, just_read_params=just_read) case ("benchmark"); call benchmark_init_temperature_salinity(tv%T, tv%S, & - G, GV, US, PF, eos, tv%P_Ref, just_read_params=just_read) + G, GV, US, PF, eos, US%RL2_T2_to_Pa*tv%P_Ref, just_read_params=just_read) case ("TS_profile") ; call initialize_temp_salt_from_profile(tv%T, tv%S, & G, PF, just_read_params=just_read) case ("linear"); call initialize_temp_salt_linear(tv%T, tv%S, G, PF, & @@ -1734,7 +1734,7 @@ subroutine initialize_sponges_file(G, GV, US, use_temperature, tv, param_file, C tmp_2d ! A temporary array for tracers. real :: Idamp(SZI_(G),SZJ_(G)) ! The inverse damping rate [T-1 ~> s-1]. - real :: pres(SZI_(G)) ! An array of the reference pressure [Pa]. + real :: pres(SZI_(G)) ! An array of the reference pressure [R L2 T-2 ~> Pa]. integer :: i, j, k, is, ie, js, je, nz integer :: isd, ied, jsd, jed @@ -1870,8 +1870,7 @@ subroutine initialize_sponges_file(G, GV, US, use_temperature, tv, param_file, C call MOM_read_data(filename, salin_var, tmp2(:,:,:), G%Domain) do j=js,je - call calculate_density(tmp(:,j,1), tmp2(:,j,1), pres, tmp_2d(:,j), & - is, ie-is+1, tv%eqn_of_state, scale=US%kg_m3_to_R) + call calculate_density(tmp(:,j,1), tmp2(:,j,1), pres, tmp_2d(:,j), G%HI, tv%eqn_of_state, US) enddo call set_up_sponge_ML_density(tmp_2d, G, CSp) @@ -2016,7 +2015,7 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, G, GV, US, PF, just_read_param real, dimension(:,:,:), allocatable :: rho_z ! Densities in Z-space [R ~> kg m-3] real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1) :: zi ! Interface heights [Z ~> m]. integer, dimension(SZI_(G),SZJ_(G)) :: nlevs - real, dimension(SZI_(G)) :: press ! Pressures [Pa]. + real, dimension(SZI_(G)) :: press ! Pressures [R L2 T-2 ~> Pa]. ! Local variables for ALE remapping real, dimension(:), allocatable :: hTarget ! Target thicknesses [Z ~> m]. @@ -2185,14 +2184,13 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, G, GV, US, PF, just_read_param allocate(area_shelf_h(isd:ied,jsd:jed)) allocate(frac_shelf_h(isd:ied,jsd:jed)) - press(:) = tv%P_Ref - ! Convert T&S to Absolute Salinity and Conservative Temperature if using TEOS10 or NEMO + press(:) = US%RL2_T2_to_Pa*tv%P_Ref call convert_temp_salt_for_TEOS10(temp_z, salt_z, press, G, kd, mask_z, eos) + press(:) = tv%P_Ref do k=1,kd ; do j=js,je - call calculate_density(temp_z(:,j,k), salt_z(:,j,k), press, rho_z(:,j,k), is, ie, & - eos, scale=US%kg_m3_to_R) + call calculate_density(temp_z(:,j,k), salt_z(:,j,k), press, rho_z(:,j,k), G%HI, eos, US) enddo ; enddo call pass_var(temp_z,G%Domain) @@ -2399,7 +2397,7 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, G, GV, US, PF, just_read_param if (adjust_temperature .and. .not. useALEremapping) then call determine_temperature(tv%T(is:ie,js:je,:), tv%S(is:ie,js:je,:), & - GV%Rlay(1:nz), tv%P_Ref, niter, missing_value, h(is:ie,js:je,:), ks, US, eos) + GV%Rlay(1:nz), US%RL2_T2_to_Pa*tv%P_Ref, niter, missing_value, h(is:ie,js:je,:), ks, US, eos) endif deallocate(z_in, z_edges_in, temp_z, salt_z, mask_z) diff --git a/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 b/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 index 88c9e47ba4..eae9c94f17 100644 --- a/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 +++ b/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 @@ -376,7 +376,7 @@ subroutine bulkmixedlayer(h_3d, u_3d, v_3d, tv, fluxes, dt, ea, eb, G, GV, US, C Idt_diag = 1.0 / (dt__diag) write_diags = .true. ; if (present(last_call)) write_diags = last_call - p_ref(:) = 0.0 ; p_ref_cv(:) = US%kg_m3_to_R*US%m_s_to_L_T**2*tv%P_Ref + p_ref(:) = 0.0 ; p_ref_cv(:) = tv%P_Ref nsw = CS%nsw diff --git a/src/parameterizations/vertical/MOM_diabatic_aux.F90 b/src/parameterizations/vertical/MOM_diabatic_aux.F90 index 32a909fed4..c67fd65679 100644 --- a/src/parameterizations/vertical/MOM_diabatic_aux.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_aux.F90 @@ -427,7 +427,7 @@ subroutine insert_brine(h, tv, G, GV, US, fluxes, nkmb, CS, dt, id_brine_lay) ! because it is not convergent when resolution becomes very fine. I think that this whole ! subroutine needs to be revisited.- RWH - p_ref_cv(:) = US%kg_m3_to_R*US%m_s_to_L_T**2*tv%P_Ref + p_ref_cv(:) = tv%P_Ref brine_dz = 1.0*GV%m_to_H inject_layer(:,:) = nz @@ -458,7 +458,8 @@ subroutine insert_brine(h, tv, G, GV, US, fluxes, nkmb, CS, dt, id_brine_lay) if ((G%mask2dT(i,j) > 0.0) .and. dzbr(i) < brine_dz .and. salt(i) > 0.) then s_new = S(i,k) + salt(i) / (GV%H_to_RZ * h_2d(i,k)) t0 = T(i,k) - call calculate_density(t0, s_new, tv%P_Ref, R_new, tv%eqn_of_state, scale=US%kg_m3_to_R) + call calculate_density(t0, s_new, tv%P_Ref, R_new, tv%eqn_of_state, & + scale=US%kg_m3_to_R, pres_scale=US%RL2_T2_to_Pa) if (R_new < 0.5*(Rcv(i,k)+Rcv(i,k+1)) .and. s_new0) .and. .not.use_BBL_EOS) then - do i=Isq,Ieq+1 ; p_ref(i) = US%kg_m3_to_R*US%m_s_to_L_T**2*tv%P_Ref ; enddo + do i=Isq,Ieq+1 ; p_ref(i) = tv%P_Ref ; enddo !$OMP parallel do default(shared) do k=1,nkmb ; do j=Jsq,Jeq+1 call calculate_density(tv%T(:,j,k), tv%S(:,j,k), p_ref, Rml(:,j,k), G%HI, & diff --git a/src/tracer/MOM_tracer_hor_diff.F90 b/src/tracer/MOM_tracer_hor_diff.F90 index d18bb3e330..93ca34257c 100644 --- a/src/tracer/MOM_tracer_hor_diff.F90 +++ b/src/tracer/MOM_tracer_hor_diff.F90 @@ -671,7 +671,7 @@ subroutine tracer_epipycnal_ML_diff(h, dt, Tr, ntr, khdt_epi_x, khdt_epi_y, G, & left_set, & ! If true, the left or right point determines the density of right_set ! of the trio. If densities are exactly equal, both are true. real :: tmp - real :: p_ref_cv(SZI_(G)) + real :: p_ref_cv(SZI_(G)) ! The reference pressure for the coordinate density [R L2 T-2 ~> Pa] integer :: k_max, k_min, k_test, itmp integer :: i, j, k, k2, m, is, ie, js, je, nz, nkmb @@ -698,8 +698,8 @@ subroutine tracer_epipycnal_ML_diff(h, dt, Tr, ntr, khdt_epi_x, khdt_epi_y, G, & ! Determine which layers the mixed- and buffer-layers map into... !$OMP parallel do default(shared) do k=1,nkmb ; do j=js-2,je+2 - call calculate_density(tv%T(:,j,k),tv%S(:,j,k), p_ref_cv, & - rho_coord(:,j,k), is-2, ie-is+5, tv%eqn_of_state, scale=US%kg_m3_to_R) + call calculate_density(tv%T(:,j,k),tv%S(:,j,k), p_ref_cv, rho_coord(:,j,k), G%HI, & + tv%eqn_of_state, US, halo=2) enddo ; enddo do j=js-2,je+2 ; do i=is-2,ie+2 diff --git a/src/user/DOME_initialization.F90 b/src/user/DOME_initialization.F90 index f582ca0c7a..4dfa145746 100644 --- a/src/user/DOME_initialization.F90 +++ b/src/user/DOME_initialization.F90 @@ -261,7 +261,7 @@ subroutine DOME_set_OBC_data(OBC, tv, G, GV, US, param_file, tr_Reg) ! Local variables ! 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 [Pa]. + real :: pres(SZK_(G)) ! An array of the reference pressure [R L2 T-2 ~> Pa]. real :: drho_dT(SZK_(G)) ! Derivative of density with temperature [R degC-1 ~> kg m-3 degC-1]. real :: drho_dS(SZK_(G)) ! Derivative of density with salinity [R ppt-1 ~> kg m-3 ppt-1]. real :: rho_guess(SZK_(G)) ! Potential density at T0 & S0 [R ~> kg m-3]. @@ -359,13 +359,17 @@ subroutine DOME_set_OBC_data(OBC, tv, G, GV, US, param_file, tr_Reg) ! target density and a salinity of 35 psu. This code is taken from ! USER_initialize_temp_sal. pres(:) = tv%P_Ref ; S0(:) = 35.0 ; T0(1) = 25.0 - call calculate_density(T0(1),S0(1),pres(1),rho_guess(1),tv%eqn_of_state, scale=US%kg_m3_to_R) - call calculate_density_derivs(T0,S0,pres,drho_dT,drho_dS,1,1,tv%eqn_of_state, scale=US%kg_m3_to_R) + call calculate_density(T0(1), S0(1), pres(1), rho_guess(1), tv%eqn_of_state, & + scale=US%kg_m3_to_R, pres_scale=US%RL2_T2_to_Pa) + call calculate_density_derivs(T0, S0, pres, drho_dT, drho_dS, 1, 1, tv%eqn_of_state, & + scale=US%kg_m3_to_R, pres_scale=US%RL2_T2_to_Pa) do k=1,nz ; T0(k) = T0(1) + (GV%Rlay(k)-rho_guess(1)) / drho_dT(1) ; enddo do itt=1,6 - call calculate_density(T0,S0,pres,rho_guess,1,nz,tv%eqn_of_state, scale=US%kg_m3_to_R) - call calculate_density_derivs(T0,S0,pres,drho_dT,drho_dS,1,nz,tv%eqn_of_state, scale=US%kg_m3_to_R) + call calculate_density(T0, S0, pres, rho_guess, 1, nz, tv%eqn_of_state, & + scale=US%kg_m3_to_R, pres_scale=US%RL2_T2_to_Pa) + call calculate_density_derivs(T0, S0, pres, drho_dT, drho_dS, 1, nz, tv%eqn_of_state, & + scale=US%kg_m3_to_R, pres_scale=US%RL2_T2_to_Pa) do k=1,nz ; T0(k) = T0(k) + (GV%Rlay(k)-rho_guess(k)) / drho_dT(k) ; enddo enddo diff --git a/src/user/RGC_initialization.F90 b/src/user/RGC_initialization.F90 index ae28bb36c6..6dbee6cea7 100644 --- a/src/user/RGC_initialization.F90 +++ b/src/user/RGC_initialization.F90 @@ -77,7 +77,7 @@ subroutine RGC_initialize_sponges(G, GV, US, tv, u, v, PF, use_ALE, CSp, ACSp) real :: h(SZI_(G),SZJ_(G),SZK_(G)) ! A temporary array for thickness at h points real :: Idamp(SZI_(G),SZJ_(G)) ! The inverse damping rate at h points [T-1 ~> s-1]. real :: TNUDG ! Nudging time scale [T ~> s] - real :: pres(SZI_(G)) ! An array of the reference pressure, in Pa + real :: pres(SZI_(G)) ! An array of the reference pressure [R L2 T-2 ~> Pa] real :: e0(SZK_(G)+1) ! The resting interface heights, in m, usually ! ! negative because it is positive upward. ! real :: eta(SZI_(G),SZJ_(G),SZK_(G)+1) ! A temporary array for eta. @@ -213,8 +213,7 @@ subroutine RGC_initialize_sponges(G, GV, US, tv, u, v, PF, use_ALE, CSp, ACSp) do i=is-1,ie ; pres(i) = tv%P_Ref ; enddo do j=js,je - call calculate_density(T(:,j,1), S(:,j,1), pres, tmp(:,j), & - is, ie-is+1, tv%eqn_of_state, scale=US%kg_m3_to_R) + call calculate_density(T(:,j,1), S(:,j,1), pres, tmp(:,j), G%HI, tv%eqn_of_state, US) enddo call set_up_sponge_ML_density(tmp, G, CSp) diff --git a/src/user/user_change_diffusivity.F90 b/src/user/user_change_diffusivity.F90 index 86f3e6e99a..f33d772352 100644 --- a/src/user/user_change_diffusivity.F90 +++ b/src/user/user_change_diffusivity.F90 @@ -66,7 +66,7 @@ subroutine user_change_diff(h, tv, G, GV, US, CS, Kd_lay, Kd_int, T_f, S_f, Kd_i !! each interface [Z2 T-1 ~> m2 s-1]. ! Local variables real :: Rcv(SZI_(G),SZK_(G)) ! The coordinate density in layers [R ~> kg m-3]. - real :: p_ref(SZI_(G)) ! An array of tv%P_Ref pressures. + real :: p_ref(SZI_(G)) ! An array of tv%P_Ref pressures [R L2 T-2 ~> Pa]. real :: rho_fn ! The density dependence of the input function, 0-1 [nondim]. real :: lat_fn ! The latitude dependence of the input function, 0-1 [nondim]. logical :: use_EOS ! If true, density is calculated from T & S using an @@ -107,13 +107,11 @@ subroutine user_change_diff(h, tv, G, GV, US, CS, Kd_lay, Kd_int, T_f, S_f, Kd_i do j=js,je if (present(T_f) .and. present(S_f)) then do k=1,nz - call calculate_density(T_f(:,j,k), S_f(:,j,k), p_ref, Rcv(:,k),& - is, ie-is+1, tv%eqn_of_state, scale=US%kg_m3_to_R) + call calculate_density(T_f(:,j,k), S_f(:,j,k), p_ref, Rcv(:,k), G%HI, tv%eqn_of_state, US) enddo else do k=1,nz - call calculate_density(tv%T(:,j,k), tv%S(:,j,k), p_ref, Rcv(:,k),& - is, ie-is+1, tv%eqn_of_state, scale=US%kg_m3_to_R) + call calculate_density(tv%T(:,j,k), tv%S(:,j,k), p_ref, Rcv(:,k), G%HI, tv%eqn_of_state, US) enddo endif From fb820c1e757f6b321eea1ff33c9e046c6be4602c Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sat, 11 Apr 2020 21:03:18 -0400 Subject: [PATCH 166/316] +Rescaled pressure arguments to multiple routines Rescaled the reference pressure arguments to 3 set_coord routines, 5 initialization routines, and kappa_shear_column. Also removed the unused pres argument to convert_temp_salt_for_TEOS10 and replaced its ocean_grid_type argument with a hor_index_type. All answers are bitwise identical. --- src/equation_of_state/MOM_EOS.F90 | 27 +++++++------- .../MOM_coord_initialization.F90 | 37 ++++++++++--------- .../MOM_state_initialization.F90 | 35 ++++++++++-------- .../vertical/MOM_kappa_shear.F90 | 34 ++++++++--------- src/tracer/MOM_tracer_Z_init.F90 | 14 ++++--- src/user/Neverland_initialization.F90 | 2 +- src/user/benchmark_initialization.F90 | 35 +++++++++++------- 7 files changed, 101 insertions(+), 83 deletions(-) diff --git a/src/equation_of_state/MOM_EOS.F90 b/src/equation_of_state/MOM_EOS.F90 index cfd286450e..fb2a1b1ca6 100644 --- a/src/equation_of_state/MOM_EOS.F90 +++ b/src/equation_of_state/MOM_EOS.F90 @@ -3129,19 +3129,16 @@ subroutine int_spec_vol_dp_generic_plm(T_t, T_b, S_t, S_b, p_t, p_b, alpha_ref, 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 - - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - real, dimension(SZI_(G),SZJ_(G), SZK_(G)), & +subroutine convert_temp_salt_for_TEOS10(T, S, HI, kd, mask_z, EOS) + integer, intent(in) :: kd !< The number of layers to work on + type(hor_index_type), intent(in) :: HI !< The horizontal index structure + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed,kd), & intent(inout) :: T !< Potential temperature referenced to the surface [degC] - real, dimension(SZI_(G),SZJ_(G), SZK_(G)), & + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed,kd), & intent(inout) :: S !< Salinity [ppt] - real, dimension(:), intent(in) :: press !< Pressure at the top of the layer [Pa]. - type(EOS_type), pointer :: EOS !< Equation of state structure - real, dimension(SZI_(G),SZJ_(G), SZK_(G)), & + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed,kd), & intent(in) :: mask_z !< 3d mask regulating which points to convert. - integer, intent(in) :: kd !< The number of layers to work on + type(EOS_type), pointer :: EOS !< Equation of state structure integer :: i,j,k real :: gsw_sr_from_sp, gsw_ct_from_pt, gsw_sa_from_sp @@ -3152,12 +3149,14 @@ subroutine convert_temp_salt_for_TEOS10(T, S, press, G, kd, mask_z, EOS) 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 + do k=1,kd ; do j=HI%jsc,HI%jec ; do i=HI%isc,HI%iec 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)) +! Get absolute salnity from practical salinity, converting pressures from Pascal to dbar. +! If this option is activated, pressure will need to be added as an argument, and it should be +! moved out into module that is not shared between components, where the ocean_grid can be used. +! S(i,j,k) = gsw_sa_from_sp(S(i,j,k),pres(i,j,k)*1.0e-4,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 end subroutine convert_temp_salt_for_TEOS10 diff --git a/src/initialization/MOM_coord_initialization.F90 b/src/initialization/MOM_coord_initialization.F90 index d4afa115af..691ca4a60c 100644 --- a/src/initialization/MOM_coord_initialization.F90 +++ b/src/initialization/MOM_coord_initialization.F90 @@ -89,11 +89,11 @@ subroutine MOM_initialize_coord(GV, US, PF, write_geom, output_dir, tv, max_dept case ("linear") call set_coord_linear(GV%Rlay, GV%g_prime, GV, US, PF) case ("ts_ref") - call set_coord_from_ts_ref(GV%Rlay, GV%g_prime, GV, US, PF, eos, US%RL2_T2_to_Pa*tv%P_Ref) + call set_coord_from_TS_ref(GV%Rlay, GV%g_prime, GV, US, PF, eos, tv%P_Ref) case ("ts_profile") - call set_coord_from_TS_profile(GV%Rlay, GV%g_prime, GV, US, PF, eos, US%RL2_T2_to_Pa*tv%P_Ref) + call set_coord_from_TS_profile(GV%Rlay, GV%g_prime, GV, US, PF, eos, tv%P_Ref) case ("ts_range") - call set_coord_from_TS_range(GV%Rlay, GV%g_prime, GV, US, PF, eos, US%RL2_T2_to_Pa*tv%P_Ref) + call set_coord_from_TS_range(GV%Rlay, GV%g_prime, GV, US, PF, eos, tv%P_Ref) case ("file") call set_coord_from_file(GV%Rlay, GV%g_prime, GV, US, PF) case ("USER") @@ -198,8 +198,7 @@ subroutine set_coord_from_layer_density(Rlay, g_prime, GV, US, param_file) end subroutine set_coord_from_layer_density !> Sets the layer densities (Rlay) and the interface reduced gravities (g) from a profile of g'. -subroutine set_coord_from_TS_ref(Rlay, g_prime, GV, US, param_file, eqn_of_state, & - P_Ref) +subroutine set_coord_from_TS_ref(Rlay, g_prime, GV, US, param_file, eqn_of_state, P_Ref) real, dimension(:), intent(out) :: Rlay !< The layers' target coordinate values !! (potential density) [R ~> kg m-3]. real, dimension(:), intent(out) :: g_prime !< The reduced gravity across the interfaces @@ -209,7 +208,8 @@ subroutine set_coord_from_TS_ref(Rlay, g_prime, GV, US, param_file, eqn_of_state type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time !! parameters type(EOS_type), pointer :: eqn_of_state !< integer selecting the equation of state. - real, intent(in) :: P_Ref !< The coordinate-density reference pressure [Pa]. + real, intent(in) :: P_Ref !< The coordinate-density reference pressure + !! [R L2 T-2 ~> Pa]. ! Local variables real :: T_ref ! Reference temperature real :: S_ref ! Reference salinity @@ -240,7 +240,8 @@ subroutine set_coord_from_TS_ref(Rlay, g_prime, GV, US, param_file, eqn_of_state ! The uppermost layer's density is set here. Subsequent layers' ! ! densities are determined from this value and the g values. ! ! T0 = 28.228 ; S0 = 34.5848 ; Pref = P_Ref - call calculate_density(T_ref, S_ref, P_ref, Rlay(1), eqn_of_state, scale=US%kg_m3_to_R) + call calculate_density(T_ref, S_ref, P_ref, Rlay(1), eqn_of_state, & + scale=US%kg_m3_to_R, pres_scale=US%RL2_T2_to_Pa) ! These statements set the layer densities. ! do k=2,nz ; Rlay(k) = Rlay(k-1) + g_prime(k)*(GV%Rho0/GV%g_Earth) ; enddo @@ -249,8 +250,7 @@ subroutine set_coord_from_TS_ref(Rlay, g_prime, GV, US, param_file, eqn_of_state end subroutine set_coord_from_TS_ref !> Sets the layer densities (Rlay) and the interface reduced gravities (g) from a T-S profile. -subroutine set_coord_from_TS_profile(Rlay, g_prime, GV, US, param_file, & - eqn_of_state, P_Ref) +subroutine set_coord_from_TS_profile(Rlay, g_prime, GV, US, param_file, eqn_of_state, P_Ref) real, dimension(:), intent(out) :: Rlay !< The layers' target coordinate values !! (potential density) [R ~> kg m-3]. real, dimension(:), intent(out) :: g_prime !< The reduced gravity across the interfaces @@ -260,7 +260,9 @@ subroutine set_coord_from_TS_profile(Rlay, g_prime, GV, US, param_file, & 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 equation of state. - real, intent(in) :: P_Ref !< The coordinate-density reference pressure [Pa]. + real, intent(in) :: P_Ref !< The coordinate-density reference pressure + !! [R L2 T-2 ~> Pa]. + ! Local variables real, dimension(GV%ke) :: T0, S0, Pref real :: g_fs ! Reduced gravity across the free surface [L2 Z-1 T-2 ~> m s-2]. @@ -289,16 +291,15 @@ subroutine set_coord_from_TS_profile(Rlay, g_prime, GV, US, param_file, & " set_coord_from_TS_profile: Unable to open " //trim(filename)) ! These statements set the interface reduced gravities. ! g_prime(1) = g_fs - do k=1,nz ; Pref(k) = P_ref ; enddo - call calculate_density(T0, S0, Pref, Rlay, 1, nz, eqn_of_state, scale=US%kg_m3_to_R) + do k=1,nz ; Pref(k) = P_Ref ; enddo + call calculate_density(T0, S0, Pref, Rlay, 1, nz, eqn_of_state, scale=US%kg_m3_to_R, pres_scale=US%RL2_T2_to_Pa) do k=2,nz; g_prime(k) = (GV%g_Earth/(GV%Rho0)) * (Rlay(k) - Rlay(k-1)) ; enddo call callTree_leave(trim(mdl)//'()') end subroutine set_coord_from_TS_profile !> Sets the layer densities (Rlay) and the interface reduced gravities (g) from a linear T-S profile. -subroutine set_coord_from_TS_range(Rlay, g_prime, GV, US, param_file, & - eqn_of_state, P_Ref) +subroutine set_coord_from_TS_range(Rlay, g_prime, GV, US, param_file, eqn_of_state, P_Ref) real, dimension(:), intent(out) :: Rlay !< The layers' target coordinate values !! (potential density) [R ~> kg m-3]. real, dimension(:), intent(out) :: g_prime !< The reduced gravity across the interfaces @@ -308,7 +309,8 @@ subroutine set_coord_from_TS_range(Rlay, g_prime, GV, US, param_file, & 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 equation of state - real, intent(in) :: P_Ref !< The coordinate-density reference pressure [Pa] + real, intent(in) :: P_Ref !< The coordinate-density reference pressure + !! [R L2 T-2 ~> Pa]. ! Local variables real, dimension(GV%ke) :: T0, S0, Pref @@ -369,8 +371,9 @@ subroutine set_coord_from_TS_range(Rlay, g_prime, GV, US, param_file, & enddo g_prime(1) = g_fs - do k=1,nz ; Pref(k) = P_ref ; enddo - call calculate_density(T0, S0, Pref, Rlay, k_light, nz-k_light+1, eqn_of_state, scale=US%kg_m3_to_R) + do k=1,nz ; Pref(k) = P_Ref ; enddo + call calculate_density(T0, S0, Pref, Rlay, k_light, nz-k_light+1, eqn_of_state, & + scale=US%kg_m3_to_R, pres_scale=US%RL2_T2_to_Pa) ! Extrapolate target densities for the variable density mixed and buffer layers. do k=k_light-1,1,-1 Rlay(k) = 2.0*Rlay(k+1) - Rlay(k+2) diff --git a/src/initialization/MOM_state_initialization.F90 b/src/initialization/MOM_state_initialization.F90 index 6339211d3e..d58a6b4704 100644 --- a/src/initialization/MOM_state_initialization.F90 +++ b/src/initialization/MOM_state_initialization.F90 @@ -291,9 +291,9 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, US, PF, dirs, & case ("ISOMIP"); call ISOMIP_initialize_thickness(h, G, GV, US, PF, tv, & just_read_params=just_read) case ("benchmark"); call benchmark_initialize_thickness(h, G, GV, US, PF, & - tv%eqn_of_state, US%RL2_T2_to_Pa*tv%P_Ref, just_read_params=just_read) + tv%eqn_of_state, tv%P_Ref, just_read_params=just_read) case ("Neverland"); call Neverland_initialize_thickness(h, G, GV, US, PF, & - tv%eqn_of_state, US%RL2_T2_to_Pa*tv%P_Ref) + tv%eqn_of_state, tv%P_Ref) case ("search"); call initialize_thickness_search case ("circle_obcs"); call circle_obcs_initialize_thickness(h, G, GV, PF, & just_read_params=just_read) @@ -348,11 +348,11 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, US, PF, dirs, & ! " \t baroclinic_zone - an analytic baroclinic zone. \n"//& select case (trim(config)) case ("fit"); call initialize_temp_salt_fit(tv%T, tv%S, G, GV, US, PF, & - eos, US%RL2_T2_to_Pa*tv%P_Ref, just_read_params=just_read) + eos, tv%P_Ref, just_read_params=just_read) case ("file"); call initialize_temp_salt_from_file(tv%T, tv%S, G, & PF, just_read_params=just_read) case ("benchmark"); call benchmark_init_temperature_salinity(tv%T, tv%S, & - G, GV, US, PF, eos, US%RL2_T2_to_Pa*tv%P_Ref, just_read_params=just_read) + G, GV, US, PF, eos, tv%P_Ref, just_read_params=just_read) case ("TS_profile") ; call initialize_temp_salt_from_profile(tv%T, tv%S, & G, PF, just_read_params=just_read) case ("linear"); call initialize_temp_salt_linear(tv%T, tv%S, G, PF, & @@ -1561,7 +1561,7 @@ subroutine initialize_temp_salt_fit(T, S, G, GV, US, param_file, eqn_of_state, P !! parameters. type(EOS_type), pointer :: eqn_of_state !< Integer that selects the equatio of state. real, intent(in) :: P_Ref !< The coordinate-density reference pressure - !! [Pa]. + !! [R L2 T-2 ~> Pa]. logical, optional, intent(in) :: just_read_params !< If present and true, this call will !! only read parameters without changing h. ! Local variables @@ -1569,7 +1569,7 @@ subroutine initialize_temp_salt_fit(T, S, G, GV, US, param_file, eqn_of_state, P real :: S0(SZK_(G)) ! Layer salinities [degC] real :: T_Ref ! Reference Temperature [degC] real :: S_Ref ! Reference Salinity [ppt] - real :: pres(SZK_(G)) ! An array of the reference pressure [Pa]. + real :: pres(SZK_(G)) ! An array of the reference pressure [R L2 T-2 ~> Pa]. real :: drho_dT(SZK_(G)) ! Derivative of density with temperature [R degC-1 ~> kg m-3 degC-1]. real :: drho_dS(SZK_(G)) ! Derivative of density with salinity [R ppt-1 ~> kg m-3 ppt-1]. real :: rho_guess(SZK_(G)) ! Potential density at T0 & S0 [R ~> kg m-3]. @@ -1601,8 +1601,10 @@ subroutine initialize_temp_salt_fit(T, S, G, GV, US, param_file, eqn_of_state, P T0(k) = T_Ref enddo - call calculate_density(T0(1),S0(1),pres(1),rho_guess(1),eqn_of_state, scale=US%kg_m3_to_R) - call calculate_density_derivs(T0,S0,pres,drho_dT,drho_dS,1,1,eqn_of_state, scale=US%kg_m3_to_R) + call calculate_density(T0(1), S0(1), pres(1), rho_guess(1), eqn_of_state, & + scale=US%kg_m3_to_R, pres_scale=US%RL2_T2_to_Pa) + call calculate_density_derivs(T0, S0, pres, drho_dT, drho_dS, 1, 1, eqn_of_state, & + scale=US%kg_m3_to_R, pres_scale=US%RL2_T2_to_Pa) if (fit_salin) then ! A first guess of the layers' temperatures. @@ -1611,8 +1613,10 @@ subroutine initialize_temp_salt_fit(T, S, G, GV, US, param_file, eqn_of_state, P enddo ! Refine the guesses for each layer. do itt=1,6 - call calculate_density(T0,S0,pres,rho_guess,1,nz,eqn_of_state, scale=US%kg_m3_to_R) - call calculate_density_derivs(T0,S0,pres,drho_dT,drho_dS,1,nz,eqn_of_state, scale=US%kg_m3_to_R) + call calculate_density(T0, S0, pres, rho_guess, 1, nz, eqn_of_state, & + scale=US%kg_m3_to_R, pres_scale=US%RL2_T2_to_Pa) + call calculate_density_derivs(T0, S0, pres, drho_dT, drho_dS, 1, nz, eqn_of_state, & + scale=US%kg_m3_to_R, pres_scale=US%RL2_T2_to_Pa) do k=1,nz S0(k) = max(0.0, S0(k) + (GV%Rlay(k) - rho_guess(k)) / drho_dS(k)) enddo @@ -1623,8 +1627,10 @@ subroutine initialize_temp_salt_fit(T, S, G, GV, US, param_file, eqn_of_state, P T0(k) = T0(1) + (GV%Rlay(k) - rho_guess(1)) / drho_dT(1) enddo do itt=1,6 - call calculate_density(T0,S0,pres,rho_guess,1,nz,eqn_of_state, scale=US%kg_m3_to_R) - call calculate_density_derivs(T0,S0,pres,drho_dT,drho_dS,1,nz,eqn_of_state, scale=US%kg_m3_to_R) + call calculate_density(T0, S0, pres, rho_guess, 1, nz, eqn_of_state, & + scale=US%kg_m3_to_R, pres_scale=US%RL2_T2_to_Pa) + call calculate_density_derivs(T0, S0, pres, drho_dT, drho_dS, 1, nz, eqn_of_state, & + scale=US%kg_m3_to_R, pres_scale=US%RL2_T2_to_Pa) do k=1,nz T0(k) = T0(k) + (GV%Rlay(k) - rho_guess(k)) / drho_dT(k) enddo @@ -2185,8 +2191,7 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, G, GV, US, PF, just_read_param allocate(frac_shelf_h(isd:ied,jsd:jed)) ! Convert T&S to Absolute Salinity and Conservative Temperature if using TEOS10 or NEMO - press(:) = US%RL2_T2_to_Pa*tv%P_Ref - call convert_temp_salt_for_TEOS10(temp_z, salt_z, press, G, kd, mask_z, eos) + call convert_temp_salt_for_TEOS10(temp_z, salt_z, G%HI, kd, mask_z, eos) press(:) = tv%P_Ref do k=1,kd ; do j=js,je @@ -2397,7 +2402,7 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, G, GV, US, PF, just_read_param if (adjust_temperature .and. .not. useALEremapping) then call determine_temperature(tv%T(is:ie,js:je,:), tv%S(is:ie,js:je,:), & - GV%Rlay(1:nz), US%RL2_T2_to_Pa*tv%P_Ref, niter, missing_value, h(is:ie,js:je,:), ks, US, eos) + GV%Rlay(1:nz), tv%P_Ref, niter, missing_value, h(is:ie,js:je,:), ks, US, eos) endif deallocate(z_in, z_edges_in, temp_z, salt_z, mask_z) diff --git a/src/parameterizations/vertical/MOM_kappa_shear.F90 b/src/parameterizations/vertical/MOM_kappa_shear.F90 index 6d773c67a0..781085e794 100644 --- a/src/parameterizations/vertical/MOM_kappa_shear.F90 +++ b/src/parameterizations/vertical/MOM_kappa_shear.F90 @@ -160,7 +160,7 @@ subroutine Calculate_kappa_shear(u_in, v_in, h, tv, p_surf, kappa_io, tke_io, & kappa_avg, & ! The time-weighted average of kappa [Z2 T-1 ~> m2 s-1]. tke_avg ! The time-weighted average of TKE [Z2 T-2 ~> m2 s-2]. real :: f2 ! The squared Coriolis parameter of each column [T-2 ~> s-2]. - real :: surface_pres ! The top surface pressure [Pa]. + real :: surface_pres ! The top surface pressure [R L2 T-2 ~> Pa]. real :: dz_in_lay ! The running sum of the thickness in a layer [Z ~> m]. real :: k0dt ! The background diffusivity times the timestep [Z2 ~> m2]. @@ -283,7 +283,7 @@ subroutine Calculate_kappa_shear(u_in, v_in, h, tv, p_surf, kappa_io, tke_io, & endif f2 = 0.25 * ((G%CoriolisBu(I,j)**2 + G%CoriolisBu(I-1,J-1)**2) + & (G%CoriolisBu(I,J-1)**2 + G%CoriolisBu(I-1,J)**2)) - surface_pres = 0.0 ; if (associated(p_surf)) surface_pres = US%RL2_T2_to_Pa*p_surf(i,j) + surface_pres = 0.0 ; if (associated(p_surf)) surface_pres = p_surf(i,j) ! ---------------------------------------------------- I_Ld2_1d, dz_Int_1d @@ -430,7 +430,7 @@ subroutine Calc_kappa_shear_vertex(u_in, v_in, h, T_in, S_in, tv, p_surf, kappa_ kappa_avg, & ! The time-weighted average of kappa [Z2 T-1 ~> m2 s-1]. tke_avg ! The time-weighted average of TKE [Z2 T-2 ~> m2 s-2]. real :: f2 ! The squared Coriolis parameter of each column [T-2 ~> s-2]. - real :: surface_pres ! The top surface pressure [Pa]. + real :: surface_pres ! The top surface pressure [R L2 T-2 ~> Pa]. real :: dz_in_lay ! The running sum of the thickness in a layer [Z ~> m]. real :: k0dt ! The background diffusivity times the timestep [Z2 ~> m2]. @@ -585,8 +585,8 @@ subroutine Calc_kappa_shear_vertex(u_in, v_in, h, T_in, S_in, tv, p_surf, kappa_ endif f2 = G%CoriolisBu(I,J)**2 surface_pres = 0.0 ; if (associated(p_surf)) & - surface_pres = 0.25 * US%RL2_T2_to_Pa*((p_surf(i,j) + p_surf(i+1,j+1)) + & - (p_surf(i+1,j) + p_surf(i,j+1))) + surface_pres = 0.25 * ((p_surf(i,j) + p_surf(i+1,j+1)) + & + (p_surf(i+1,j) + p_surf(i,j+1))) ! ---------------------------------------------------- ! Set the initial guess for kappa, here defined at interfaces. @@ -661,7 +661,7 @@ subroutine Calc_kappa_shear_vertex(u_in, v_in, h, T_in, S_in, tv, p_surf, kappa_ if (CS%debug) then call hchksum(kappa_io, "kappa", G%HI, scale=US%Z2_T_to_m2_s) - call Bchksum(tke_io, "tke", G%HI) + call Bchksum(tke_io, "tke", G%HI, scale=US%Z_to_m**2*US%s_to_T**2) endif if (CS%id_Kd_shear > 0) call post_data(CS%id_Kd_shear, kappa_io, CS%diag) @@ -679,7 +679,6 @@ subroutine kappa_shear_column(kappa, tke, dt, nzc, f2, surface_pres, & dz, u0xdz, v0xdz, T0xdz, S0xdz, kappa_avg, & tke_avg, tv, CS, GV, US, I_Ld2_1d, dz_Int_1d) type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real, dimension(SZK_(GV)+1), & intent(inout) :: kappa !< The time-weighted average of kappa [Z2 T-1 ~> m2 s-1]. real, dimension(SZK_(GV)+1), & @@ -687,7 +686,7 @@ subroutine kappa_shear_column(kappa, tke, dt, nzc, f2, surface_pres, & !! an interface [Z2 T-2 ~> m2 s-2]. integer, intent(in) :: nzc !< The number of active layers in the column. real, intent(in) :: f2 !< The square of the Coriolis parameter [T-2 ~> s-2]. - real, intent(in) :: surface_pres !< The surface pressure [Pa]. + real, intent(in) :: surface_pres !< The surface pressure [R L2 T-2 ~> Pa]. real, dimension(SZK_(GV)), & intent(in) :: dz !< The layer thickness [Z ~> m]. real, dimension(SZK_(GV)), & @@ -708,6 +707,7 @@ subroutine kappa_shear_column(kappa, tke, dt, nzc, f2, surface_pres, & !! have NULL ptrs. type(Kappa_shear_CS), pointer :: CS !< The control structure returned by a previous !! call to kappa_shear_init. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real, dimension(SZK_(GV)+1), & optional, intent(out) :: I_Ld2_1d !< The inverse of the squared mixing length [Z-2 ~> m-2]. real, dimension(SZK_(GV)+1), & @@ -741,15 +741,15 @@ subroutine kappa_shear_column(kappa, tke, dt, nzc, f2, surface_pres, & kappa_mid, & ! The average of the initial and predictor estimates of kappa [Z2 T-1 ~> m2 s-1]. tke_pred, & ! The value of TKE from a predictor step [Z2 T-2 ~> m2 s-2]. kappa_pred, & ! The value of kappa from a predictor step [Z2 T-1 ~> m2 s-1]. - pressure, & ! The pressure at an interface [Pa]. + pressure, & ! The pressure at an interface [R L2 T-2 ~> Pa]. T_int, & ! The temperature interpolated to an interface [degC]. Sal_int, & ! The salinity interpolated to an interface [ppt]. dbuoy_dT, & ! The partial derivatives of buoyancy with changes in temperature dbuoy_dS, & ! and salinity, [Z T-2 degC-1 ~> m s-2 degC-1] and [Z T-2 ppt-1 ~> m s-2 ppt-1]. I_L2_bdry, & ! The inverse of the square of twice the harmonic mean ! distance to the top and bottom boundaries [Z-2 ~> m-2]. - K_Q, & ! Diffusivity divided by TKE [Z2 m-2 s2 T-1 ~> s]. - K_Q_tmp, & ! A temporary copy of diffusivity divided by TKE [Z2 m-2 s2 T-1 ~> s]. + K_Q, & ! Diffusivity divided by TKE [T ~> s]. + K_Q_tmp, & ! A temporary copy of diffusivity divided by TKE [T ~> s]. local_src_avg, & ! The time-integral of the local source [nondim]. tol_min, & ! Minimum tolerated ksrc for the corrector step [T-1 ~> s-1]. tol_max, & ! Maximum tolerated ksrc for the corrector step [T-1 ~> s-1]. @@ -762,8 +762,8 @@ subroutine kappa_shear_column(kappa, tke, dt, nzc, f2, surface_pres, & real :: b1 ! The inverse of the pivot in the tridiagonal equations. real :: bd1 ! A term in the denominator of b1. real :: d1 ! 1 - c1 in the tridiagonal equations. - real :: gR0 ! A conversion factor from Z to Pa equal to Rho_0 times g - ! [Pa Z-1 = kg m-1 s-2 Z-1 ~> kg m-2 s-2]. + real :: gR0 ! A conversion factor from Z to pressure, given by Rho_0 times g + ! [R L2 T-2 Z-1 ~> kg m-2 s-2]. real :: g_R0 ! g_R0 is a rescaled version of g/Rho [Z R-1 T-2 ~> m4 kg-1 s-2]. real :: Norm ! A factor that normalizes two weights to 1 [Z-2 ~> m-2]. real :: tol_dksrc ! Tolerance for the change in the kappa source within an iteration @@ -813,7 +813,7 @@ subroutine kappa_shear_column(kappa, tke, dt, nzc, f2, surface_pres, & #endif Ri_crit = CS%Rino_crit - gR0 = GV%z_to_H*GV%H_to_Pa + gR0 = GV%Rho0 * GV%g_Earth g_R0 = (US%L_to_Z**2 * GV%g_Earth) / (GV%Rho0) k0dt = dt*CS%kappa_0 @@ -910,8 +910,8 @@ subroutine kappa_shear_column(kappa, tke, dt, nzc, f2, surface_pres, & T_int(K) = 0.5*(T(k-1) + T(k)) Sal_int(K) = 0.5*(Sal(k-1) + Sal(k)) enddo - call calculate_density_derivs(T_int, Sal_int, pressure, dbuoy_dT, & - dbuoy_dS, 2, nzc-1, tv%eqn_of_state, scale=-g_R0*US%kg_m3_to_R) + call calculate_density_derivs(T_int, Sal_int, pressure, dbuoy_dT, dbuoy_dS, 2, nzc-1, & + tv%eqn_of_state, scale=-g_R0*US%kg_m3_to_R, pres_scale=US%RL2_T2_to_Pa) else do K=1,nzc+1 ; dbuoy_dT(K) = -g_R0 ; dbuoy_dS(K) = 0.0 ; enddo endif @@ -1388,7 +1388,7 @@ subroutine find_kappa_tke(N2, S2, kappa_in, Idz, dz_Int, I_L2_bdry, f2, & type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real, dimension(nz+1), intent(inout) :: K_Q !< The shear-driven diapycnal diffusivity divided by !! the turbulent kinetic energy per unit mass at - !! interfaces [Z2 m-2 s2 T-1 ~> s]. + !! interfaces [T ~> s]. real, dimension(nz+1), intent(out) :: tke !< The turbulent kinetic energy per unit mass at !! interfaces [Z2 T-2 ~> m2 s-2]. real, dimension(nz+1), intent(out) :: kappa !< The diapycnal diffusivity at interfaces diff --git a/src/tracer/MOM_tracer_Z_init.F90 b/src/tracer/MOM_tracer_Z_init.F90 index aaa670070b..948705f4b3 100644 --- a/src/tracer/MOM_tracer_Z_init.F90 +++ b/src/tracer/MOM_tracer_Z_init.F90 @@ -744,7 +744,7 @@ subroutine determine_temperature(temp, salt, R_tgt, p_ref, niter, land_fill, h, real, dimension(:,:,:), intent(inout) :: temp !< potential temperature [degC] real, dimension(:,:,:), intent(inout) :: salt !< salinity [PSU] real, dimension(size(temp,3)), intent(in) :: R_tgt !< desired potential density [R ~> kg m-3]. - real, intent(in) :: p_ref !< reference pressure [Pa]. + real, intent(in) :: p_ref !< reference pressure [R L2 T-2 ~> Pa]. integer, intent(in) :: niter !< maximum number of iterations integer, intent(in) :: k_start !< starting index (i.e. below the buffer layer) real, intent(in) :: land_fill !< land fill value @@ -763,7 +763,7 @@ subroutine determine_temperature(temp, salt, R_tgt, p_ref, niter, land_fill, h, hin, & ! Input layer thicknesses [H ~> m or kg m-2] drho_dT, & ! Partial derivative of density with temperature [R degC-1 ~> kg m-3 degC-1] drho_dS ! Partial derivative of density with salinity [R ppt-1 ~> kg m-3 ppt-1] - real, dimension(size(temp,1)) :: press + real, dimension(size(temp,1)) :: press ! Reference pressures [R L2 T-2 ~> Pa] integer :: nx, ny, nz, nt, i, j, k, n, itt real :: dT_dS_gauge ! The relative penalizing of temperature to salinity changes when ! minimizing property changes while correcting density [degC ppt-1]. @@ -801,9 +801,10 @@ subroutine determine_temperature(temp, salt, R_tgt, p_ref, niter, land_fill, h, adjust_salt = .true. iter_loop: do itt = 1,niter do k=1, nz - call calculate_density(T(:,k), S(:,k), press, rho(:,k), 1, nx, eos, scale=US%kg_m3_to_R) + call calculate_density(T(:,k), S(:,k), press, rho(:,k), 1, nx, eos, & + scale=US%kg_m3_to_R, pres_scale=US%RL2_T2_to_Pa) call calculate_density_derivs(T(:,k), S(:,k), press, drho_dT(:,k), drho_dS(:,k), 1, nx, & - eos, scale=US%kg_m3_to_R) + eos, scale=US%kg_m3_to_R, pres_scale=US%RL2_T2_to_Pa) enddo do k=k_start,nz ; do i=1,nx @@ -831,9 +832,10 @@ subroutine determine_temperature(temp, salt, R_tgt, p_ref, niter, land_fill, h, if (adjust_salt .and. old_fit) then ; do itt = 1,niter do k=1, nz - call calculate_density(T(:,k), S(:,k), press, rho(:,k), 1, nx, eos, scale=US%kg_m3_to_R) + call calculate_density(T(:,k), S(:,k), press, rho(:,k), 1, nx, eos, & + scale=US%kg_m3_to_R, pres_scale=US%RL2_T2_to_Pa) call calculate_density_derivs(T(:,k), S(:,k), press, drho_dT(:,k), drho_dS(:,k), 1, nx, & - eos, scale=US%kg_m3_to_R) + eos, scale=US%kg_m3_to_R, pres_scale=US%RL2_T2_to_Pa) enddo do k=k_start,nz ; do i=1,nx ! if (abs(rho(i,k)-R_tgt(k))>tol_rho .and. hin(i,k)>h_massless .and. abs(T(i,k)-land_fill) < epsln ) then diff --git a/src/user/Neverland_initialization.F90 b/src/user/Neverland_initialization.F90 index 949530e773..64afe85ab5 100644 --- a/src/user/Neverland_initialization.F90 +++ b/src/user/Neverland_initialization.F90 @@ -122,7 +122,7 @@ subroutine Neverland_initialize_thickness(h, G, GV, US, param_file, eqn_of_state type(EOS_type), pointer :: eqn_of_state !< integer that selects the !! equation of state. real, intent(in) :: P_Ref !< The coordinate-density - !! reference pressure [Pa]. + !! reference pressure [R L2 T-2 ~> Pa]. ! Local variables real :: e0(SZK_(G)+1) ! The resting interface heights, in depth units [Z ~> m], ! usually negative because it is positive upward. diff --git a/src/user/benchmark_initialization.F90 b/src/user/benchmark_initialization.F90 index 5641035ded..a173150b9d 100644 --- a/src/user/benchmark_initialization.F90 +++ b/src/user/benchmark_initialization.F90 @@ -83,7 +83,7 @@ end subroutine benchmark_initialize_topography !! temperature profile with an exponentially decaying thermocline on top of a !! linear stratification. subroutine benchmark_initialize_thickness(h, G, GV, US, param_file, eqn_of_state, & - P_ref, just_read_params) + 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. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type @@ -94,7 +94,7 @@ subroutine benchmark_initialize_thickness(h, G, GV, US, param_file, eqn_of_state type(EOS_type), pointer :: eqn_of_state !< integer that selects the !! equation of state. real, intent(in) :: P_Ref !< The coordinate-density - !! reference pressure [Pa]. + !! reference pressure [R L2 T-2 ~> Pa]. logical, optional, intent(in) :: just_read_params !< If present and true, this call will !! only read parameters without changing h. ! Local variables @@ -109,10 +109,11 @@ subroutine benchmark_initialize_thickness(h, G, GV, US, param_file, eqn_of_state real :: ML_depth ! The specified initial mixed layer depth, in depth units [Z ~> m]. real :: thermocline_scale ! The e-folding scale of the thermocline, in depth units [Z ~> m]. real, dimension(SZK_(GV)) :: & - T0, pres, S0, & ! drho + T0, S0, & ! Profiles of temperature [degC] and salinity [ppt] rho_guess, & ! Potential density at T0 & S0 [R ~> kg m-3]. drho_dT, & ! Derivative of density with temperature [R degC-1 ~> kg m-3 degC-1]. drho_dS ! Derivative of density with salinity [R ppt-1 ~> kg m-3 ppt-1]. + real :: pres(SZK_(GV)) ! Reference pressure [R L2 T-2 ~> Pa]. real :: a_exp ! The fraction of the overall stratification that is exponential. real :: I_ts, I_md ! Inverse lengthscales [Z-1 ~> m-1]. real :: T_frac ! A ratio of the interface temperature to the range @@ -151,8 +152,10 @@ subroutine benchmark_initialize_thickness(h, G, GV, US, param_file, eqn_of_state pres(k) = P_Ref ; S0(k) = 35.0 enddo T0(k1) = 29.0 - call calculate_density(T0(k1), S0(k1), pres(k1), rho_guess(k1), eqn_of_state, scale=US%kg_m3_to_R) - call calculate_density_derivs(T0, S0, pres, drho_dT, drho_dS, k1, 1, eqn_of_state, scale=US%kg_m3_to_R) + call calculate_density(T0(k1), S0(k1), pres(k1), rho_guess(k1), eqn_of_state, & + scale=US%kg_m3_to_R, pres_scale=US%RL2_T2_to_Pa) + call calculate_density_derivs(T0, S0, pres, drho_dT, drho_dS, k1, 1, eqn_of_state, & + scale=US%kg_m3_to_R, pres_scale=US%RL2_T2_to_Pa) ! A first guess of the layers' temperatures. do k=1,nz @@ -161,8 +164,10 @@ subroutine benchmark_initialize_thickness(h, G, GV, US, param_file, eqn_of_state ! Refine the guesses for each layer. do itt=1,6 - call calculate_density(T0, S0, pres, rho_guess, 1, nz, eqn_of_state, scale=US%kg_m3_to_R) - call calculate_density_derivs(T0, S0, pres, drho_dT, drho_dS, 1, nz, eqn_of_state, scale=US%kg_m3_to_R) + call calculate_density(T0, S0, pres, rho_guess, 1, nz, eqn_of_state, & + scale=US%kg_m3_to_R, pres_scale=US%RL2_T2_to_Pa) + call calculate_density_derivs(T0, S0, pres, drho_dT, drho_dS, 1, nz, eqn_of_state, & + scale=US%kg_m3_to_R, pres_scale=US%RL2_T2_to_Pa) do k=1,nz T0(k) = T0(k) + (GV%Rlay(k) - rho_guess(k)) / drho_dT(k) enddo @@ -227,12 +232,12 @@ subroutine benchmark_init_temperature_salinity(T, S, G, GV, US, param_file, & type(EOS_type), pointer :: eqn_of_state !< integer that selects the !! equation of state. real, intent(in) :: P_Ref !< The coordinate-density - !! reference pressure [Pa]. + !! reference pressure [R L2 T-2 ~> Pa]. logical, optional, intent(in) :: just_read_params !< If present and true, this call will !! only read parameters without changing h. ! Local variables real :: T0(SZK_(G)), S0(SZK_(G)) - real :: pres(SZK_(G)) ! Reference pressure [Pa]. + real :: pres(SZK_(G)) ! Reference pressure [R L2 T-2 ~> Pa]. real :: drho_dT(SZK_(G)) ! Derivative of density with temperature [R degC-1 ~> kg m-3 degC-1]. real :: drho_dS(SZK_(G)) ! Derivative of density with salinity [R ppt-1 ~> kg m-3 ppt-1]. real :: rho_guess(SZK_(G)) ! Potential density at T0 & S0 [R ~> kg m-3]. @@ -256,8 +261,10 @@ subroutine benchmark_init_temperature_salinity(T, S, G, GV, US, param_file, & enddo T0(k1) = 29.0 - call calculate_density(T0(k1),S0(k1),pres(k1),rho_guess(k1),eqn_of_state, scale=US%kg_m3_to_R) - call calculate_density_derivs(T0,S0,pres,drho_dT,drho_dS,k1,1,eqn_of_state, scale=US%kg_m3_to_R) + call calculate_density(T0(k1), S0(k1), pres(k1), rho_guess(k1), eqn_of_state, & + scale=US%kg_m3_to_R, pres_scale=US%RL2_T2_to_Pa) + call calculate_density_derivs(T0, S0, pres, drho_dT, drho_dS, k1, 1, eqn_of_state, & + scale=US%kg_m3_to_R, pres_scale=US%RL2_T2_to_Pa) ! A first guess of the layers' temperatures. ! do k=1,nz @@ -266,8 +273,10 @@ subroutine benchmark_init_temperature_salinity(T, S, G, GV, US, param_file, & ! Refine the guesses for each layer. ! do itt = 1,6 - call calculate_density(T0,S0,pres,rho_guess,1,nz,eqn_of_state, scale=US%kg_m3_to_R) - call calculate_density_derivs(T0,S0,pres,drho_dT,drho_dS,1,nz,eqn_of_state, scale=US%kg_m3_to_R) + call calculate_density(T0,S0,pres,rho_guess,1,nz,eqn_of_state, & + scale=US%kg_m3_to_R, pres_scale=US%RL2_T2_to_Pa) + call calculate_density_derivs(T0,S0,pres,drho_dT,drho_dS,1,nz,eqn_of_state, & + scale=US%kg_m3_to_R, pres_scale=US%RL2_T2_to_Pa) do k=1,nz T0(k) = T0(k) + (GV%Rlay(k) - rho_guess(k)) / drho_dT(k) enddo From 6948cb7439fe78fba804271d800e5c1ca9538c09 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sun, 12 Apr 2020 08:39:04 -0400 Subject: [PATCH 167/316] +Replaced optional pres_scale args with US args Replaced the remaining pres_scale arguments the various calculate_density and calc_spec_vol routines in MOM_EOS.F90 with new optional unit_scale_type arguments. When the scale and US arguments are present, density is scaled by the product of the indicated scaling factors. Calls to these routines in 11 files were modified accordingly. All answers are bitwise identical. --- src/core/MOM_isopycnal_slopes.F90 | 4 +- src/equation_of_state/MOM_EOS.F90 | 309 +++++++++--------- .../MOM_coord_initialization.F90 | 8 +- .../MOM_state_initialization.F90 | 18 +- .../vertical/MOM_diabatic_aux.F90 | 3 +- .../vertical/MOM_diabatic_driver.F90 | 1 - .../vertical/MOM_geothermal.F90 | 6 +- .../vertical/MOM_kappa_shear.F90 | 2 +- .../vertical/MOM_set_viscosity.F90 | 4 +- src/tracer/MOM_tracer_Z_init.F90 | 10 +- src/user/DOME_initialization.F90 | 12 +- src/user/benchmark_initialization.F90 | 24 +- 12 files changed, 195 insertions(+), 206 deletions(-) diff --git a/src/core/MOM_isopycnal_slopes.F90 b/src/core/MOM_isopycnal_slopes.F90 index 00b5264251..78fdc51077 100644 --- a/src/core/MOM_isopycnal_slopes.F90 +++ b/src/core/MOM_isopycnal_slopes.F90 @@ -176,7 +176,7 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, & S_u(I) = 0.25*((S(i,j,k) + S(i+1,j,k)) + (S(i,j,k-1) + S(i+1,j,k-1))) enddo call calculate_density_derivs(T_u, S_u, pres_u, drho_dT_u, drho_dS_u, (is-IsdB+1)-1, ie-is+2, & - tv%eqn_of_state, scale=US%kg_m3_to_R, pres_scale=US%RL2_T2_to_Pa) + tv%eqn_of_state, US=US) endif do I=is-1,ie @@ -262,7 +262,7 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, & S_v(i) = 0.25*((S(i,j,k) + S(i,j+1,k)) + (S(i,j,k-1) + S(i,j+1,k-1))) enddo call calculate_density_derivs(T_v, S_v, pres_v, drho_dT_v, drho_dS_v, is, ie-is+1, & - tv%eqn_of_state, scale=US%kg_m3_to_R, pres_scale=US%RL2_T2_to_Pa) + tv%eqn_of_state, US=US) endif do i=is,ie if (use_EOS) then diff --git a/src/equation_of_state/MOM_EOS.F90 b/src/equation_of_state/MOM_EOS.F90 index fb2a1b1ca6..2c518f5af1 100644 --- a/src/equation_of_state/MOM_EOS.F90 +++ b/src/equation_of_state/MOM_EOS.F90 @@ -140,24 +140,27 @@ module MOM_EOS contains !> Calls the appropriate subroutine to calculate density of sea water for scalar inputs. -!! 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, scale, pres_scale) +!! If rho_ref is present, the anomaly with respect to rho_ref is returned. The pressure and +!! density can be rescaled with the US. If both the US and scale arguments are present the density +!! scaling uses the product of the two scaling factors. +subroutine calculate_density_scalar(T, S, pressure, rho, EOS, rho_ref, US, scale) real, intent(in) :: T !< Potential temperature referenced to the surface [degC] real, intent(in) :: S !< Salinity [ppt] - real, intent(in) :: pressure !< Pressure [Pa] or [other ~> Pa] + real, intent(in) :: pressure !< Pressure [Pa] or [R L2 T-2 ~> Pa] real, intent(out) :: rho !< Density (in-situ if pressure is local) [kg m-3] or [R ~> kg m-3] type(EOS_type), pointer :: EOS !< Equation of state structure real, optional, intent(in) :: rho_ref !< A reference density [kg m-3]. - real, optional, intent(in) :: scale !< A multiplicative factor by which to scale density - !! from kg m-3 to the desired units [R m3 kg-1] - real, optional, intent(in) :: pres_scale !< A multiplicative factor to convert pressure into Pa. + type(unit_scale_type), optional, intent(in) :: US !< A dimensional unit scaling type + real, optional, intent(in) :: scale !< A multiplicative factor by which to scale density in + !! combination with scaling given by US [various] + real :: rho_scale ! A factor to convert density from kg m-3 to the desired units [R m3 kg-1 ~> 1] real :: p_scale ! A factor to convert pressure to units of Pa. if (.not.associated(EOS)) call MOM_error(FATAL, & "calculate_density_scalar called with an unassociated EOS_type EOS.") - p_scale = 1.0 ; if (present(pres_scale)) p_scale = pres_scale + p_scale = 1.0 ; if (present(US)) p_scale = US%RL2_T2_to_Pa select case (EOS%form_of_EOS) case (EOS_LINEAR) @@ -175,15 +178,17 @@ subroutine calculate_density_scalar(T, S, pressure, rho, EOS, rho_ref, scale, pr call MOM_error(FATAL, "calculate_density_scalar: EOS is not valid.") end select - if (present(scale)) then ; if (scale /= 1.0) then - rho = scale * rho - endif ; endif + if (present(US) .or. present(scale)) then + rho_scale = 1.0 ; if (present(US)) rho_scale = US%kg_m3_to_R + if (present(scale)) rho_scale = rho_scale * scale + rho = rho_scale * rho + endif end subroutine calculate_density_scalar !> Calls the appropriate subroutine to calculate the density of sea water for 1-D array inputs. !! 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, scale, pres_scale) +subroutine calculate_density_array(T, S, pressure, rho, start, npts, EOS, rho_ref, US, scale) real, dimension(:), intent(in) :: T !< Potential temperature referenced to the surface [degC] real, dimension(:), intent(in) :: S !< Salinity [ppt] real, dimension(:), intent(in) :: pressure !< Pressure [Pa] or [other ~> Pa] @@ -191,19 +196,20 @@ subroutine calculate_density_array(T, S, pressure, rho, start, npts, EOS, rho_re 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 [kg m-3]. - real, optional, intent(in) :: scale !< A multiplicative factor by which to scale density - !! from kg m-3 to the desired units [R m3 kg-1] - real, optional, intent(in) :: pres_scale !< A multiplicative factor to convert pressure into Pa. + real, optional, intent(in) :: rho_ref !< A reference density [kg m-3]. + type(unit_scale_type), optional, intent(in) :: US !< A dimensional unit scaling type + real, optional, intent(in) :: scale !< A multiplicative factor by which to scale density + !! in combination with scaling given by US [various] - real :: p_scale ! A factor to convert pressure to units of Pa. + real :: p_scale ! A factor to convert pressure to units of Pa. + real :: rho_scale ! A factor to convert density from kg m-3 to the desired units [R m3 kg-1 ~> 1] real, dimension(size(pressure)) :: pres ! Pressure converted to [Pa] integer :: j if (.not.associated(EOS)) call MOM_error(FATAL, & "calculate_density_array called with an unassociated EOS_type EOS.") - p_scale = 1.0 ; if (present(pres_scale)) p_scale = pres_scale + p_scale = 1.0 ; if (present(US)) p_scale = US%RL2_T2_to_Pa if (p_scale == 1.0) then select case (EOS%form_of_EOS) @@ -240,16 +246,18 @@ subroutine calculate_density_array(T, S, pressure, rho, start, npts, EOS, rho_re end select endif - if (present(scale)) then ; if (scale /= 1.0) then - do j=start,start+npts-1 ; rho(j) = scale * rho(j) ; enddo - endif ; endif + rho_scale = 1.0 ; if (present(US)) rho_scale = US%kg_m3_to_R + if (present(scale)) rho_scale = rho_scale * scale + if (rho_scale /= 1.0) then + do j=start,start+npts-1 ; rho(j) = rho_scale * rho(j) ; enddo + endif end subroutine calculate_density_array !> Calls the appropriate subroutine to calculate the density of sea water for 1-D array inputs !! using array extents determined from a hor_index_type. !! If rho_ref is present, the anomaly with respect to rho_ref is returned. -subroutine calculate_density_HI_1d(T, S, pressure, rho, HI, EOS, US, halo, rho_ref) +subroutine calculate_density_HI_1d(T, S, pressure, rho, HI, EOS, US, halo) type(hor_index_type), intent(in) :: HI !< The horizontal index structure real, dimension(HI%isd:HI%ied), intent(in) :: T !< Potential temperature referenced to the surface [degC] real, dimension(HI%isd:HI%ied), intent(in) :: S !< Salinity [ppt] @@ -258,11 +266,9 @@ subroutine calculate_density_HI_1d(T, S, pressure, rho, HI, EOS, US, halo, rho_r type(EOS_type), pointer :: EOS !< Equation of state structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type integer, optional, intent(in) :: halo !< The halo size to work on; missing is equivalent to 0. - real, optional, intent(in) :: rho_ref !< A reference density [kg m-3]. ! Local variables real, dimension(HI%isd:HI%ied) :: pres ! Pressure converted to [Pa] - real :: rho_reference ! rho_ref converted to [kg m-3] integer :: i, is, ie, start, npts, halo_sz if (.not.associated(EOS)) call MOM_error(FATAL, & @@ -278,38 +284,19 @@ subroutine calculate_density_HI_1d(T, S, pressure, rho, HI, EOS, US, halo, rho_r 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, rho_ref) - case (EOS_UNESCO) - 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, rho_ref) - case (EOS_TEOS10) - 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, rho_ref) - case default - call MOM_error(FATAL, "calculate_density_HI_1d: EOS%form_of_EOS is not valid.") - end select - elseif (present(rho_ref)) then ! This is the same as above, but with some extra work to rescale variables. - do i=is,ie ; pres(i) = US%RL2_T2_to_Pa * pressure(i) ; enddo - rho_reference = 0.0 ; if (present(rho_ref)) rho_reference = US%R_to_kg_m3*rho_ref - select case (EOS%form_of_EOS) - case (EOS_LINEAR) - call calculate_density_linear(T, S, pres, rho, start, npts, & - EOS%Rho_T0_S0-rho_reference, EOS%dRho_dT, EOS%dRho_dS) + EOS%Rho_T0_S0, EOS%dRho_dT, EOS%dRho_dS) case (EOS_UNESCO) - call calculate_density_unesco(T, S, pres, rho, start, npts, rho_reference) + call calculate_density_unesco(T, S, pressure, rho, start, npts) case (EOS_WRIGHT) - call calculate_density_wright(T, S, pres, rho, start, npts, rho_reference) + call calculate_density_wright(T, S, pressure, rho, start, npts) case (EOS_TEOS10) - call calculate_density_teos10(T, S, pres, rho, start, npts, rho_reference) + call calculate_density_teos10(T, S, pressure, rho, start, npts) case (EOS_NEMO) - call calculate_density_nemo(T, S, pres, rho, start, npts, rho_reference) + call calculate_density_nemo(T, S, pressure, rho, start, npts) case default call MOM_error(FATAL, "calculate_density_HI_1d: EOS%form_of_EOS is not valid.") end select - else ! There is rescaling of variables, but rho_ref is not present. Passing a 0 value of rho_ref - ! changes answers at roundoff for some equations of state, like Wright and UNESCO. + else ! There is rescaling of variables, including pressure. do i=is,ie ; pres(i) = US%RL2_T2_to_Pa * pressure(i) ; enddo select case (EOS%form_of_EOS) case (EOS_LINEAR) @@ -336,24 +323,25 @@ end subroutine calculate_density_HI_1d !> 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, scale, pres_scale) +subroutine calculate_spec_vol_scalar(T, S, pressure, specvol, EOS, spv_ref, US, scale) real, intent(in) :: T !< Potential temperature referenced to the surface [degC] real, intent(in) :: S !< Salinity [ppt] - real, intent(in) :: pressure !< Pressure [Pa] + real, intent(in) :: pressure !< Pressure [Pa] or [R L2 T-2 ~> Pa] real, intent(out) :: specvol !< In situ? specific volume [m3 kg-1] or [R-1 ~> m3 kg-1] type(EOS_type), pointer :: EOS !< Equation of state structure real, optional, intent(in) :: spv_ref !< A reference specific volume [m3 kg-1]. + type(unit_scale_type), optional, intent(in) :: US !< A dimensional unit scaling type real, optional, intent(in) :: scale !< A multiplicative factor by which to scale specific - !! volume from m3 kg-1 to the desired units [kg m-3 R-1] - real, optional, intent(in) :: pres_scale !< A multiplicative factor to convert pressure into Pa. + !! volume in combination with scaling given by US [various] real :: p_scale ! A factor to convert pressure to units of Pa. - real :: rho + real :: rho ! Density [kg m-3] + real :: spv_scale ! A factor to convert specific volume from m3 kg-1 to the desired units [kg R-1 m-3 ~> 1] if (.not.associated(EOS)) call MOM_error(FATAL, & "calculate_spec_vol_scalar called with an unassociated EOS_type EOS.") - p_scale = 1.0 ; if (present(pres_scale)) p_scale = pres_scale + p_scale = 1.0 ; if (present(US)) p_scale = US%RL2_T2_to_Pa select case (EOS%form_of_EOS) case (EOS_LINEAR) @@ -376,36 +364,39 @@ subroutine calculate_spec_vol_scalar(T, S, pressure, specvol, EOS, spv_ref, scal call MOM_error(FATAL, "calculate_spec_vol_scalar: EOS is not valid.") end select - if (present(scale)) then ; if (scale /= 1.0) then - specvol = scale * specvol - endif ; endif + spv_scale = 1.0 ; if (present(US)) spv_scale = US%R_to_kg_m3 + if (present(scale)) spv_scale = spv_scale * scale + if (spv_scale /= 1.0) then + specvol = spv_scale * specvol + endif 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, scale, pres_scale) +subroutine calculate_spec_vol_array(T, S, pressure, specvol, start, npts, EOS, spv_ref, US, scale) real, dimension(:), intent(in) :: T !< potential temperature relative to the surface [degC]. real, dimension(:), intent(in) :: S !< salinity [ppt]. - real, dimension(:), intent(in) :: pressure !< pressure [Pa]. + real, dimension(:), intent(in) :: pressure !< pressure [Pa] or [R L2 T-2 ~> Pa]. real, dimension(:), intent(inout) :: specvol !< in situ specific volume [kg m-3] or [R-1 ~> m3 kg-1]. 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 [m3 kg-1]. - real, optional, intent(in) :: scale !< A multiplicative factor by which to scale specific volume - !! from m3 kg-1 to the desired units [kg m-3 R-1] - real, optional, intent(in) :: pres_scale !< A multiplicative factor to convert pressure into Pa. + type(unit_scale_type), optional, intent(in) :: US !< A dimensional unit scaling type + real, optional, intent(in) :: scale !< A multiplicative factor by which to scale specific + !! volume in combination with scaling given by US [various] - real :: p_scale ! A factor to convert pressure to units of Pa. real, dimension(size(pressure)) :: pres ! Pressure converted to [Pa] - real, dimension(size(specvol)) :: rho + real, dimension(size(specvol)) :: rho ! Density [kg m-3] + real :: p_scale ! A factor to convert pressure to units of Pa. + real :: spv_scale ! A factor to convert specific volume from m3 kg-1 to the desired units [kg R-1 m-3 ~> 1] integer :: j if (.not.associated(EOS)) call MOM_error(FATAL, & "calculate_spec_vol_array called with an unassociated EOS_type EOS.") - p_scale = 1.0 ; if (present(pres_scale)) p_scale = pres_scale + p_scale = 1.0 ; if (present(US)) p_scale = US%RL2_T2_to_Pa if (p_scale == 1.0) then select case (EOS%form_of_EOS) @@ -452,9 +443,11 @@ subroutine calculate_spec_vol_array(T, S, pressure, specvol, start, npts, EOS, s end select endif - if (present(scale)) then ; if (scale /= 1.0) then ; do j=start,start+npts-1 - specvol(j) = scale * specvol(j) - enddo ; endif ; endif + spv_scale = 1.0 ; if (present(US)) spv_scale = US%R_to_kg_m3 + if (present(scale)) spv_scale = spv_scale * scale + if (spv_scale /= 1.0) then ; do j=start,start+npts-1 + specvol(j) = spv_scale * specvol(j) + enddo ; endif end subroutine calculate_spec_vol_array @@ -635,10 +628,10 @@ subroutine calculate_TFreeze_array(S, pressure, T_fr, start, npts, EOS, pres_sca end subroutine calculate_TFreeze_array !> Calls the appropriate subroutine to calculate density derivatives for 1-D array inputs. -subroutine calculate_density_derivs_array(T, S, pressure, drho_dT, drho_dS, start, npts, EOS, scale, pres_scale) +subroutine calculate_density_derivs_array(T, S, pressure, drho_dT, drho_dS, start, npts, EOS, US, scale) real, dimension(:), intent(in) :: T !< Potential temperature referenced to the surface [degC] real, dimension(:), intent(in) :: S !< Salinity [ppt] - real, dimension(:), intent(in) :: pressure !< Pressure [Pa] + real, dimension(:), intent(in) :: pressure !< Pressure [Pa] or [R L2 T-2 ~> Pa] real, dimension(:), intent(inout) :: drho_dT !< The partial derivative of density with potential !! temperature [kg m-3 degC-1] or [R degC-1 ~> kg m-3 degC-1]. real, dimension(:), intent(inout) :: drho_dS !< The partial derivative of density with salinity, @@ -646,19 +639,20 @@ subroutine calculate_density_derivs_array(T, S, pressure, drho_dT, drho_dS, star 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 - real, optional, intent(in) :: scale !< A multiplicative factor by which to scale density - !! from kg m-3 to the desired units [R m3 kg-1] - real, optional, intent(in) :: pres_scale !< A multiplicative factor to convert pressure into Pa. + type(unit_scale_type), optional, intent(in) :: US !< A dimensional unit scaling type + real, optional, intent(in) :: scale !< A multiplicative factor by which to scale density + !! in combination with scaling given by US [various] ! Local variables real, dimension(size(pressure)) :: pres ! Pressure converted to [Pa] + real :: rho_scale ! A factor to convert density from kg m-3 to the desired units [R m3 kg-1 ~> 1] real :: p_scale ! A factor to convert pressure to units of Pa. integer :: j if (.not.associated(EOS)) call MOM_error(FATAL, & "calculate_density_derivs called with an unassociated EOS_type EOS.") - p_scale = 1.0 ; if (present(pres_scale)) p_scale = pres_scale + p_scale = 1.0 ; if (present(US)) p_scale = US%RL2_T2_to_Pa if (p_scale == 1.0) then select case (EOS%form_of_EOS) @@ -695,10 +689,12 @@ subroutine calculate_density_derivs_array(T, S, pressure, drho_dT, drho_dS, star end select endif - if (present(scale)) then ; if (scale /= 1.0) then ; do j=start,start+npts-1 - drho_dT(j) = scale * drho_dT(j) - drho_dS(j) = scale * drho_dS(j) - enddo ; endif ; endif + rho_scale = 1.0 ; if (present(US)) rho_scale = US%kg_m3_to_R + if (present(scale)) rho_scale = rho_scale * scale + if (rho_scale /= 1.0) then ; do j=start,start+npts-1 + drho_dT(j) = rho_scale * drho_dT(j) + drho_dS(j) = rho_scale * drho_dS(j) + enddo ; endif end subroutine calculate_density_derivs_array @@ -719,7 +715,6 @@ subroutine calculate_density_derivs_HI_1d(T, S, pressure, drho_dT, drho_dS, HI, ! Local variables real, dimension(HI%isd:HI%ied) :: pres ! Pressure converted to [Pa] - real :: rho_reference ! rho_ref converted to [kg m-3] integer :: i, is, ie, start, npts, halo_sz if (.not.associated(EOS)) call MOM_error(FATAL, & @@ -776,25 +771,28 @@ end subroutine calculate_density_derivs_HI_1d !> 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, scale, pres_scale) +subroutine calculate_density_derivs_scalar(T, S, pressure, drho_dT, drho_dS, EOS, US, scale) real, intent(in) :: T !< Potential temperature referenced to the surface [degC] real, intent(in) :: S !< Salinity [ppt] - real, intent(in) :: pressure !< Pressure [Pa] + real, intent(in) :: pressure !< Pressure [Pa] or [R L2 T-2 ~> Pa] real, intent(out) :: drho_dT !< The partial derivative of density with potential !! temperature [kg m-3 degC-1] or [R degC-1 ~> kg m-3 degC-1] real, intent(out) :: drho_dS !< The partial derivative of density with salinity, !! in [kg m-3 ppt-1] or [R ppt-1 ~> kg m-3 ppt-1]. - type(EOS_type), pointer :: EOS !< Equation of state structure - real, optional, intent(in) :: scale !< A multiplicative factor by which to scale density - !! from kg m-3 to the desired units [R m3 kg-1] - real, optional, intent(in) :: pres_scale !< A multiplicative factor to convert pressure into Pa. + type(EOS_type), pointer :: EOS !< Equation of state structure + type(unit_scale_type), optional, intent(in) :: US !< A dimensional unit scaling type + real, optional, intent(in) :: scale !< A multiplicative factor by which to scale density + !! in combination with scaling given by US [various] + ! Local variables + real :: rho_scale ! A factor to convert density from kg m-3 to the desired units [R m3 kg-1 ~> 1] real :: p_scale ! A factor to convert pressure to units of Pa. + integer :: j if (.not.associated(EOS)) call MOM_error(FATAL, & "calculate_density_derivs called with an unassociated EOS_type EOS.") - p_scale = 1.0 ; if (present(pres_scale)) p_scale = pres_scale + p_scale = 1.0 ; if (present(US)) p_scale = US%RL2_T2_to_Pa select case (EOS%form_of_EOS) case (EOS_LINEAR) @@ -808,19 +806,21 @@ subroutine calculate_density_derivs_scalar(T, S, pressure, drho_dT, drho_dS, EOS call MOM_error(FATAL, "calculate_density_derivs_scalar: EOS%form_of_EOS is not valid.") end select - if (present(scale)) then ; if (scale /= 1.0) then - drho_dT = scale * drho_dT - drho_dS = scale * drho_dS - endif ; endif + rho_scale = 1.0 ; if (present(US)) rho_scale = US%kg_m3_to_R + if (present(scale)) rho_scale = rho_scale * scale + if (rho_scale /= 1.0) then + drho_dT = rho_scale * drho_dT + drho_dS = rho_scale * drho_dS + endif 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, scale, pres_scale) + drho_dS_dP, drho_dT_dP, start, npts, EOS, US, scale) real, dimension(:), intent(in) :: T !< Potential temperature referenced to the surface [degC] real, dimension(:), intent(in) :: S !< Salinity [ppt] - real, dimension(:), intent(in) :: pressure !< Pressure [Pa] + real, dimension(:), intent(in) :: pressure !< Pressure [Pa] or [R L2 T-2 ~> Pa] real, dimension(:), intent(inout) :: drho_dS_dS !< Partial derivative of beta with respect to S !! [kg m-3 ppt-2] or [R ppt-2 ~> kg m-3 ppt-2] real, dimension(:), intent(inout) :: drho_dS_dT !< Partial derivative of beta with respect to T @@ -832,21 +832,23 @@ subroutine calculate_density_second_derivs_array(T, S, pressure, drho_dS_dS, drh real, dimension(:), intent(inout) :: drho_dT_dP !< Partial derivative of alpha with respect to pressure !! [kg m-3 degC-1 Pa-1] or [R degC-1 Pa-1 ~> kg m-3 degC-1 Pa-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 - real, optional, intent(in) :: scale !< A multiplicative factor by which to scale density - !! from kg m-3 to the desired units [R m3 kg-1] - real, optional, intent(in) :: pres_scale !< A multiplicative factor to convert pressure into Pa. + integer, intent(in) :: npts !< The number of values to calculate + type(EOS_type), pointer :: EOS !< Equation of state structure + type(unit_scale_type), optional, intent(in) :: US !< A dimensional unit scaling type + real, optional, intent(in) :: scale !< A multiplicative factor by which to scale density + !! in combination with scaling given by US [various] + ! Local variables - real :: p_scale ! A factor to convert pressure to units of Pa. real, dimension(size(pressure)) :: pres ! Pressure converted to [Pa] + real :: rho_scale ! A factor to convert density from kg m-3 to the desired units [R m3 kg-1 ~> 1] + real :: p_scale ! A factor to convert pressure to units of Pa. real :: I_p_scale ! The inverse of the factor to convert pressure to units of Pa. integer :: j if (.not.associated(EOS)) call MOM_error(FATAL, & "calculate_density_derivs called with an unassociated EOS_type EOS.") - p_scale = 1.0 ; if (present(pres_scale)) p_scale = pres_scale + p_scale = 1.0 ; if (present(US)) p_scale = US%RL2_T2_to_Pa if (p_scale == 1.0) then select case (EOS%form_of_EOS) @@ -879,13 +881,15 @@ subroutine calculate_density_second_derivs_array(T, S, pressure, drho_dS_dS, drh end select endif - if (present(scale)) then ; if (scale /= 1.0) then ; do j=start,start+npts-1 - drho_dS_dS(j) = scale * drho_dS_dS(j) - drho_dS_dT(j) = scale * drho_dS_dT(j) - drho_dT_dT(j) = scale * drho_dT_dT(j) - drho_dS_dP(j) = scale * drho_dS_dP(j) - drho_dT_dP(j) = scale * drho_dT_dP(j) - enddo ; endif ; endif + rho_scale = 1.0 ; if (present(US)) rho_scale = US%kg_m3_to_R + if (present(scale)) rho_scale = rho_scale * scale + if (rho_scale /= 1.0) then ; do j=start,start+npts-1 + drho_dS_dS(j) = rho_scale * drho_dS_dS(j) + drho_dS_dT(j) = rho_scale * drho_dS_dT(j) + drho_dT_dT(j) = rho_scale * drho_dT_dT(j) + drho_dS_dP(j) = rho_scale * drho_dS_dP(j) + drho_dT_dP(j) = rho_scale * drho_dT_dP(j) + enddo ; endif if (p_scale /= 1.0) then I_p_scale = 1.0 / p_scale @@ -899,7 +903,7 @@ 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, scale, pres_scale) + drho_dS_dP, drho_dT_dP, EOS, US, scale) real, intent(in) :: T !< Potential temperature referenced to the surface [degC] real, intent(in) :: S !< Salinity [ppt] real, intent(in) :: pressure !< Pressure [Pa] @@ -914,17 +918,18 @@ subroutine calculate_density_second_derivs_scalar(T, S, pressure, drho_dS_dS, dr real, intent(out) :: drho_dT_dP !< Partial derivative of alpha with respect to pressure !! [kg m-3 degC-1 Pa-1] or [R degC-1 Pa-1 ~> kg m-3 degC-1 Pa-1] type(EOS_type), pointer :: EOS !< Equation of state structure - real, optional, intent(in) :: scale !< A multiplicative factor by which to scale density - !! from kg m-3 to the desired units [R m3 kg-1] - real, optional, intent(in) :: pres_scale !< A multiplicative factor to convert pressure into Pa. + type(unit_scale_type), optional, intent(in) :: US !< A dimensional unit scaling type + real, optional, intent(in) :: scale !< A multiplicative factor by which to scale density + !! in combination with scaling given by US [various] ! Local variables - real :: p_scale ! A factor to convert pressure to units of Pa. + real :: rho_scale ! A factor to convert density from kg m-3 to the desired units [R m3 kg-1 ~> 1] + real :: p_scale ! A factor to convert pressure to units of Pa. real :: I_p_scale ! The inverse of the factor to convert pressure to units of Pa. if (.not.associated(EOS)) call MOM_error(FATAL, & "calculate_density_derivs called with an unassociated EOS_type EOS.") - p_scale = 1.0 ; if (present(pres_scale)) p_scale = pres_scale + p_scale = 1.0 ; if (present(US)) p_scale = US%RL2_T2_to_Pa select case (EOS%form_of_EOS) case (EOS_LINEAR) @@ -940,13 +945,15 @@ subroutine calculate_density_second_derivs_scalar(T, S, pressure, drho_dS_dS, dr call MOM_error(FATAL, "calculate_density_derivs: EOS%form_of_EOS is not valid.") end select - if (present(scale)) then ; if (scale /= 1.0) then - drho_dS_dS = scale * drho_dS_dS - drho_dS_dT = scale * drho_dS_dT - drho_dT_dT = scale * drho_dT_dT - drho_dS_dP = scale * drho_dS_dP - drho_dT_dP = scale * drho_dT_dP - endif ; endif + rho_scale = 1.0 ; if (present(US)) rho_scale = US%kg_m3_to_R + if (present(scale)) rho_scale = rho_scale * scale + if (rho_scale /= 1.0) then + drho_dS_dS = rho_scale * drho_dS_dS + drho_dS_dT = rho_scale * drho_dS_dT + drho_dT_dT = rho_scale * drho_dT_dT + drho_dS_dP = rho_scale * drho_dS_dP + drho_dT_dP = rho_scale * drho_dT_dP + endif if (p_scale /= 1.0) then I_p_scale = 1.0 / p_scale @@ -957,10 +964,10 @@ subroutine calculate_density_second_derivs_scalar(T, S, pressure, drho_dS_dS, dr end subroutine calculate_density_second_derivs_scalar !> Calls the appropriate subroutine to calculate specific volume derivatives for an array. -subroutine calculate_spec_vol_derivs_array(T, S, pressure, dSV_dT, dSV_dS, start, npts, EOS, scale, pres_scale) +subroutine calculate_spec_vol_derivs_array(T, S, pressure, dSV_dT, dSV_dS, start, npts, EOS, US, scale) real, dimension(:), intent(in) :: T !< Potential temperature referenced to the surface [degC] real, dimension(:), intent(in) :: S !< Salinity [ppt] - real, dimension(:), intent(in) :: pressure !< Pressure [Pa] + real, dimension(:), intent(in) :: pressure !< Pressure [Pa] or [R L2 T-2 ~> Pa] real, dimension(:), intent(inout) :: dSV_dT !< The partial derivative of specific volume with potential !! temperature [m3 kg-1 degC-1] or [R-1 degC-1 ~> m3 kg-1 degC-1] real, dimension(:), intent(inout) :: dSV_dS !< The partial derivative of specific volume with salinity @@ -968,22 +975,23 @@ subroutine calculate_spec_vol_derivs_array(T, S, pressure, dSV_dT, dSV_dS, start 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 - real, optional, intent(in) :: scale !< A multiplicative factor by which to scale specific volume - !! from m3 kg-1 to the desired units [kg m-3 R-1] - real, optional, intent(in) :: pres_scale !< A multiplicative factor to convert pressure into Pa. + type(unit_scale_type), optional, intent(in) :: US !< A dimensional unit scaling type + real, optional, intent(in) :: scale !< A multiplicative factor by which to scale specific + !! volume in combination with scaling given by US [various] ! Local variables real, dimension(size(T)) :: press ! Pressure converted to [Pa] real, dimension(size(T)) :: rho ! In situ density [kg m-3] real, dimension(size(T)) :: dRho_dT ! Derivative of density with temperature [kg m-3 degC-1] real, dimension(size(T)) :: dRho_dS ! Derivative of density with salinity [kg m-3 ppt-1] - real :: p_scale ! A factor to convert pressure to units of Pa. + real :: p_scale ! A factor to convert pressure to units of Pa. + real :: spv_scale ! A factor to convert specific volume from m3 kg-1 to the desired units [kg R-1 m-3 ~> 1] integer :: j if (.not.associated(EOS)) call MOM_error(FATAL, & "calculate_spec_vol_derivs_array called with an unassociated EOS_type EOS.") - p_scale = 1.0 ; if (present(pres_scale)) p_scale = pres_scale + p_scale = 1.0 ; if (present(US)) p_scale = US%RL2_T2_to_Pa if (p_scale == 1.0) then select case (EOS%form_of_EOS) @@ -1040,10 +1048,12 @@ subroutine calculate_spec_vol_derivs_array(T, S, pressure, dSV_dT, dSV_dS, start end select endif - if (present(scale)) then ; if (scale /= 1.0) then ; do j=start,start+npts-1 - dSV_dT(j) = scale * dSV_dT(j) - dSV_dS(j) = scale * dSV_dS(j) - enddo ; endif ; endif + spv_scale = 1.0 ; if (present(US)) spv_scale = US%R_to_kg_m3 + if (present(scale)) spv_scale = spv_scale * scale + if (spv_scale /= 1.0) then ; do j=start,start+npts-1 + dSV_dT(j) = spv_scale * dSV_dT(j) + dSV_dS(j) = spv_scale * dSV_dS(j) + enddo ; endif end subroutine calculate_spec_vol_derivs_array @@ -1195,6 +1205,8 @@ subroutine calculate_compress_scalar(T, S, pressure, rho, drho_dp, EOS) rho = rhoa(1) ; drho_dp = drho_dpa(1) end subroutine calculate_compress_scalar + + !> Calls the appropriate subroutine to alculate 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 @@ -1658,9 +1670,9 @@ subroutine int_density_dz_generic(T, S, z_t, z_b, rho_ref, rho_0, G_e, HII, HIO, p5(n) = -GxRho*(z_t(i,j) - 0.25*real(n-1)*dz) enddo if (rho_scale /= 1.0) then - call calculate_density(T5, S5, p5, r5, 1, 5, EOS, rho_ref_mks, scale=rho_scale) + call calculate_density(T5, S5, p5, r5, 1, 5, EOS, rho_ref=rho_ref_mks, scale=rho_scale) else - call calculate_density(T5, S5, p5, r5, 1, 5, EOS, rho_ref_mks) + call calculate_density(T5, S5, p5, r5, 1, 5, EOS, rho_ref=rho_ref_mks) endif ! Use Bode's rule to estimate the pressure anomaly change. @@ -1704,9 +1716,9 @@ subroutine int_density_dz_generic(T, S, z_t, z_b, rho_ref, rho_0, G_e, HII, HIO, T5(n) = T5(1) ; S5(n) = S5(1) ; p5(n) = p5(n-1) + GxRho*0.25*dz enddo if (rho_scale /= 1.0) then - call calculate_density(T5, S5, p5, r5, 1, 5, EOS, rho_ref_mks, scale=rho_scale) + call calculate_density(T5, S5, p5, r5, 1, 5, EOS, rho_ref=rho_ref_mks, scale=rho_scale) else - call calculate_density(T5, S5, p5, r5, 1, 5, EOS, rho_ref_mks) + call calculate_density(T5, S5, p5, r5, 1, 5, EOS, rho_ref=rho_ref_mks) endif ! Use Bode's rule to estimate the pressure anomaly change. @@ -1750,9 +1762,9 @@ subroutine int_density_dz_generic(T, S, z_t, z_b, rho_ref, rho_0, G_e, HII, HIO, p5(n) = p5(n-1) + GxRho*0.25*dz enddo if (rho_scale /= 1.0) then - call calculate_density(T5, S5, p5, r5, 1, 5, EOS, rho_ref_mks, scale=rho_scale) + call calculate_density(T5, S5, p5, r5, 1, 5, EOS, rho_ref=rho_ref_mks, scale=rho_scale) else - call calculate_density(T5, S5, p5, r5, 1, 5, EOS, rho_ref_mks) + call calculate_density(T5, S5, p5, r5, 1, 5, EOS, rho_ref=rho_ref_mks) endif ! Use Bode's rule to estimate the pressure anomaly change. @@ -1893,9 +1905,9 @@ subroutine int_density_dz_generic_plm (T_t, T_b, S_t, S_b, z_t, z_b, rho_ref, & enddo enddo if (rho_scale /= 1.0) then - call calculate_density_array(T5, S5, p5, r5, 1, (ieq-isq+2)*5, EOS, rho_ref_mks, scale=rho_scale) + call calculate_density_array(T5, S5, p5, r5, 1, (ieq-isq+2)*5, EOS, rho_ref=rho_ref_mks, scale=rho_scale) else - call calculate_density_array(T5, S5, p5, r5, 1, (ieq-isq+2)*5, EOS, rho_ref_mks) + call calculate_density_array(T5, S5, p5, r5, 1, (ieq-isq+2)*5, EOS, rho_ref=rho_ref_mks) endif do i=isq,ieq+1 ; iin = i+ioff @@ -1977,9 +1989,9 @@ subroutine int_density_dz_generic_plm (T_t, T_b, S_t, S_b, z_t, z_b, rho_ref, & enddo if (rho_scale /= 1.0) then - call calculate_density(T15, S15, p15, r15, 1, 15*(ieq-isq+1), EOS, rho_ref_mks, scale=rho_scale) + call calculate_density(T15, S15, p15, r15, 1, 15*(ieq-isq+1), EOS, rho_ref=rho_ref_mks, scale=rho_scale) else - call calculate_density(T15, S15, p15, r15, 1, 15*(ieq-isq+1), EOS, rho_ref_mks) + call calculate_density(T15, S15, p15, r15, 1, 15*(ieq-isq+1), EOS, rho_ref=rho_ref_mks) endif do I=Isq,Ieq ; iin = i+ioff @@ -2061,10 +2073,11 @@ subroutine int_density_dz_generic_plm (T_t, T_b, S_t, S_b, z_t, z_b, rho_ref, & if (rho_scale /= 1.0) then 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, rho_ref_mks, scale=rho_scale) + r15(15*HIO%isc+1:), 1, 15*(HIO%iec-HIO%isc+1), EOS, & + rho_ref=rho_ref_mks, scale=rho_scale) else 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, rho_ref_mks) + r15(15*HIO%isc+1:), 1, 15*(HIO%iec-HIO%isc+1), EOS, rho_ref=rho_ref_mks) endif do i=HIO%isc,HIO%iec ; iin = i+ioff intz(1) = dpa(i,j) ; intz(5) = dpa(i,j+1) @@ -2329,9 +2342,9 @@ subroutine int_density_dz_generic_ppm(T, T_t, T_b, S, S_t, S_b, & enddo if (rho_scale /= 1.0) then - call calculate_density(T5, S5, p5, r5, 1, 5, EOS, rho_ref_mks, scale=rho_scale) + call calculate_density(T5, S5, p5, r5, 1, 5, EOS, rho_ref=rho_ref_mks, scale=rho_scale) else - call calculate_density(T5, S5, p5, r5, 1, 5, EOS, rho_ref_mks) + call calculate_density(T5, S5, p5, r5, 1, 5, EOS, rho_ref=rho_ref_mks) endif ! Use Bode's rule to estimate the pressure anomaly change. @@ -2392,9 +2405,9 @@ subroutine int_density_dz_generic_ppm(T, T_t, T_b, S, S_t, S_b, & enddo if (rho_scale /= 1.0) then - call calculate_density(T5, S5, p5, r5, 1, 5, EOS, rho_ref_mks, scale=rho_scale) + call calculate_density(T5, S5, p5, r5, 1, 5, EOS, rho_ref=rho_ref_mks, scale=rho_scale) else - call calculate_density(T5, S5, p5, r5, 1, 5, EOS, rho_ref_mks) + call calculate_density(T5, S5, p5, r5, 1, 5, EOS, rho_ref=rho_ref_mks) endif ! Use Bode's rule to estimate the pressure anomaly change. @@ -2443,9 +2456,9 @@ subroutine int_density_dz_generic_ppm(T, T_t, T_b, S, S_t, S_b, & S_node(7) = 0.5 * ( S_node(3) + S_node(4) ) if (rho_scale /= 1.0) then - call calculate_density( T_node, S_node, p_node, r_node, 1, 9, EOS, rho_ref_mks, scale=rho_scale ) + call calculate_density( T_node, S_node, p_node, r_node, 1, 9, EOS, rho_ref=rho_ref_mks, scale=rho_scale ) else - call calculate_density( T_node, S_node, p_node, r_node, 1, 9, EOS, rho_ref_mks) + call calculate_density( T_node, S_node, p_node, r_node, 1, 9, EOS, rho_ref=rho_ref_mks) endif r_node = r_node - rho_ref diff --git a/src/initialization/MOM_coord_initialization.F90 b/src/initialization/MOM_coord_initialization.F90 index 691ca4a60c..b0155ae603 100644 --- a/src/initialization/MOM_coord_initialization.F90 +++ b/src/initialization/MOM_coord_initialization.F90 @@ -240,8 +240,7 @@ subroutine set_coord_from_TS_ref(Rlay, g_prime, GV, US, param_file, eqn_of_state ! The uppermost layer's density is set here. Subsequent layers' ! ! densities are determined from this value and the g values. ! ! T0 = 28.228 ; S0 = 34.5848 ; Pref = P_Ref - call calculate_density(T_ref, S_ref, P_ref, Rlay(1), eqn_of_state, & - scale=US%kg_m3_to_R, pres_scale=US%RL2_T2_to_Pa) + call calculate_density(T_ref, S_ref, P_ref, Rlay(1), eqn_of_state, US=US) ! These statements set the layer densities. ! do k=2,nz ; Rlay(k) = Rlay(k-1) + g_prime(k)*(GV%Rho0/GV%g_Earth) ; enddo @@ -292,7 +291,7 @@ subroutine set_coord_from_TS_profile(Rlay, g_prime, GV, US, param_file, eqn_of_s ! These statements set the interface reduced gravities. ! g_prime(1) = g_fs do k=1,nz ; Pref(k) = P_Ref ; enddo - call calculate_density(T0, S0, Pref, Rlay, 1, nz, eqn_of_state, scale=US%kg_m3_to_R, pres_scale=US%RL2_T2_to_Pa) + call calculate_density(T0, S0, Pref, Rlay, 1, nz, eqn_of_state, US=US) do k=2,nz; g_prime(k) = (GV%g_Earth/(GV%Rho0)) * (Rlay(k) - Rlay(k-1)) ; enddo call callTree_leave(trim(mdl)//'()') @@ -372,8 +371,7 @@ subroutine set_coord_from_TS_range(Rlay, g_prime, GV, US, param_file, eqn_of_sta g_prime(1) = g_fs do k=1,nz ; Pref(k) = P_Ref ; enddo - call calculate_density(T0, S0, Pref, Rlay, k_light, nz-k_light+1, eqn_of_state, & - scale=US%kg_m3_to_R, pres_scale=US%RL2_T2_to_Pa) + call calculate_density(T0, S0, Pref, Rlay, k_light, nz-k_light+1, eqn_of_state, US=US) ! Extrapolate target densities for the variable density mixed and buffer layers. do k=k_light-1,1,-1 Rlay(k) = 2.0*Rlay(k+1) - Rlay(k+2) diff --git a/src/initialization/MOM_state_initialization.F90 b/src/initialization/MOM_state_initialization.F90 index d58a6b4704..a9ba5eee85 100644 --- a/src/initialization/MOM_state_initialization.F90 +++ b/src/initialization/MOM_state_initialization.F90 @@ -1601,10 +1601,8 @@ subroutine initialize_temp_salt_fit(T, S, G, GV, US, param_file, eqn_of_state, P T0(k) = T_Ref enddo - call calculate_density(T0(1), S0(1), pres(1), rho_guess(1), eqn_of_state, & - scale=US%kg_m3_to_R, pres_scale=US%RL2_T2_to_Pa) - call calculate_density_derivs(T0, S0, pres, drho_dT, drho_dS, 1, 1, eqn_of_state, & - scale=US%kg_m3_to_R, pres_scale=US%RL2_T2_to_Pa) + call calculate_density(T0(1), S0(1), pres(1), rho_guess(1), eqn_of_state, US=US) + call calculate_density_derivs(T0, S0, pres, drho_dT, drho_dS, 1, 1, eqn_of_state, US=US) if (fit_salin) then ! A first guess of the layers' temperatures. @@ -1613,10 +1611,8 @@ subroutine initialize_temp_salt_fit(T, S, G, GV, US, param_file, eqn_of_state, P enddo ! Refine the guesses for each layer. do itt=1,6 - call calculate_density(T0, S0, pres, rho_guess, 1, nz, eqn_of_state, & - scale=US%kg_m3_to_R, pres_scale=US%RL2_T2_to_Pa) - call calculate_density_derivs(T0, S0, pres, drho_dT, drho_dS, 1, nz, eqn_of_state, & - scale=US%kg_m3_to_R, pres_scale=US%RL2_T2_to_Pa) + call calculate_density(T0, S0, pres, rho_guess, 1, nz, eqn_of_state, US=US) + call calculate_density_derivs(T0, S0, pres, drho_dT, drho_dS, 1, nz, eqn_of_state, US=US) do k=1,nz S0(k) = max(0.0, S0(k) + (GV%Rlay(k) - rho_guess(k)) / drho_dS(k)) enddo @@ -1627,10 +1623,8 @@ subroutine initialize_temp_salt_fit(T, S, G, GV, US, param_file, eqn_of_state, P T0(k) = T0(1) + (GV%Rlay(k) - rho_guess(1)) / drho_dT(1) enddo do itt=1,6 - call calculate_density(T0, S0, pres, rho_guess, 1, nz, eqn_of_state, & - scale=US%kg_m3_to_R, pres_scale=US%RL2_T2_to_Pa) - call calculate_density_derivs(T0, S0, pres, drho_dT, drho_dS, 1, nz, eqn_of_state, & - scale=US%kg_m3_to_R, pres_scale=US%RL2_T2_to_Pa) + call calculate_density(T0, S0, pres, rho_guess, 1, nz, eqn_of_state, US=US) + call calculate_density_derivs(T0, S0, pres, drho_dT, drho_dS, 1, nz, eqn_of_state, US=US) do k=1,nz T0(k) = T0(k) + (GV%Rlay(k) - rho_guess(k)) / drho_dT(k) enddo diff --git a/src/parameterizations/vertical/MOM_diabatic_aux.F90 b/src/parameterizations/vertical/MOM_diabatic_aux.F90 index c67fd65679..55667085ea 100644 --- a/src/parameterizations/vertical/MOM_diabatic_aux.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_aux.F90 @@ -458,8 +458,7 @@ subroutine insert_brine(h, tv, G, GV, US, fluxes, nkmb, CS, dt, id_brine_lay) if ((G%mask2dT(i,j) > 0.0) .and. dzbr(i) < brine_dz .and. salt(i) > 0.) then s_new = S(i,k) + salt(i) / (GV%H_to_RZ * h_2d(i,k)) t0 = T(i,k) - call calculate_density(t0, s_new, tv%P_Ref, R_new, tv%eqn_of_state, & - scale=US%kg_m3_to_R, pres_scale=US%RL2_T2_to_Pa) + call calculate_density(t0, s_new, tv%P_Ref, R_new, tv%eqn_of_state, US=US) if (R_new < 0.5*(Rcv(i,k)+Rcv(i,k+1)) .and. s_new 0) then call calculate_density(tv%T(:,j,nkmb), tv%S(:,j,nkmb), p_Ref(:), Rcv_BL(:), isj, iej-isj+1, & - tv%eqn_of_state, scale=US%kg_m3_to_R, pres_scale=US%RL2_T2_to_Pa) + tv%eqn_of_state, US=US) else Rcv_BL(:) = -1.0 endif @@ -245,11 +245,11 @@ subroutine geothermal(h, tv, dt, ea, eb, G, GV, US, CS, halo) Rcv = 0.0 ; dRcv_dT = 0.0 ! Is this OK? else call calculate_density(tv%T(i,j,k), tv%S(i,j,k), tv%P_Ref, & - Rcv, tv%eqn_of_state, scale=US%kg_m3_to_R, pres_scale=US%RL2_T2_to_Pa) + Rcv, tv%eqn_of_state, US=US) T2(1) = tv%T(i,j,k) ; S2(1) = tv%S(i,j,k) T2(2) = tv%T(i,j,k_tgt) ; S2(2) = tv%S(i,j,k_tgt) call calculate_density_derivs(T2(:), S2(:), p_Ref(:), dRcv_dT_, dRcv_dS_, 1, 2, & - tv%eqn_of_state, scale=US%kg_m3_to_R, pres_scale=US%RL2_T2_to_Pa) + tv%eqn_of_state, US=US) dRcv_dT = 0.5*(dRcv_dT_(1) + dRcv_dT_(2)) endif diff --git a/src/parameterizations/vertical/MOM_kappa_shear.F90 b/src/parameterizations/vertical/MOM_kappa_shear.F90 index 781085e794..5e11ecee60 100644 --- a/src/parameterizations/vertical/MOM_kappa_shear.F90 +++ b/src/parameterizations/vertical/MOM_kappa_shear.F90 @@ -911,7 +911,7 @@ subroutine kappa_shear_column(kappa, tke, dt, nzc, f2, surface_pres, & Sal_int(K) = 0.5*(Sal(k-1) + Sal(k)) enddo call calculate_density_derivs(T_int, Sal_int, pressure, dbuoy_dT, dbuoy_dS, 2, nzc-1, & - tv%eqn_of_state, scale=-g_R0*US%kg_m3_to_R, pres_scale=US%RL2_T2_to_Pa) + tv%eqn_of_state, US=US, scale=-g_R0) else do K=1,nzc+1 ; dbuoy_dT(K) = -g_R0 ; dbuoy_dS(K) = 0.0 ; enddo endif diff --git a/src/parameterizations/vertical/MOM_set_viscosity.F90 b/src/parameterizations/vertical/MOM_set_viscosity.F90 index e8bdc25ba4..da3adc1ac5 100644 --- a/src/parameterizations/vertical/MOM_set_viscosity.F90 +++ b/src/parameterizations/vertical/MOM_set_viscosity.F90 @@ -1397,7 +1397,7 @@ subroutine set_viscous_ML(u, v, h, tv, forces, visc, dt, G, GV, US, CS, symmetri if (use_EOS) then call calculate_density_derivs(T_EOS, S_EOS, forces%p_surf(:,j), dR_dT, dR_dS, & - Isq-G%IsdB+1, Ieq-Isq+1, tv%eqn_of_state, scale=US%kg_m3_to_R, pres_scale=US%RL2_T2_to_PA) + Isq-G%IsdB+1, Ieq-Isq+1, tv%eqn_of_state, US=US) endif do I=Isq,Ieq ; if (do_i(I)) then @@ -1634,7 +1634,7 @@ subroutine set_viscous_ML(u, v, h, tv, forces, visc, dt, G, GV, US, CS, symmetri if (use_EOS) then call calculate_density_derivs(T_EOS, S_EOS, forces%p_surf(:,j), dR_dT, dR_dS, & - is-G%IsdB+1, ie-is+1, tv%eqn_of_state, scale=US%kg_m3_to_R, pres_scale=US%RL2_T2_to_PA) + is-G%IsdB+1, ie-is+1, tv%eqn_of_state, US=US) endif do i=is,ie ; if (do_i(i)) then diff --git a/src/tracer/MOM_tracer_Z_init.F90 b/src/tracer/MOM_tracer_Z_init.F90 index 948705f4b3..76ca2dac4a 100644 --- a/src/tracer/MOM_tracer_Z_init.F90 +++ b/src/tracer/MOM_tracer_Z_init.F90 @@ -801,10 +801,9 @@ subroutine determine_temperature(temp, salt, R_tgt, p_ref, niter, land_fill, h, adjust_salt = .true. iter_loop: do itt = 1,niter do k=1, nz - call calculate_density(T(:,k), S(:,k), press, rho(:,k), 1, nx, eos, & - scale=US%kg_m3_to_R, pres_scale=US%RL2_T2_to_Pa) + call calculate_density(T(:,k), S(:,k), press, rho(:,k), 1, nx, eos, US=US) call calculate_density_derivs(T(:,k), S(:,k), press, drho_dT(:,k), drho_dS(:,k), 1, nx, & - eos, scale=US%kg_m3_to_R, pres_scale=US%RL2_T2_to_Pa) + eos, US=US) enddo do k=k_start,nz ; do i=1,nx @@ -832,10 +831,9 @@ subroutine determine_temperature(temp, salt, R_tgt, p_ref, niter, land_fill, h, if (adjust_salt .and. old_fit) then ; do itt = 1,niter do k=1, nz - call calculate_density(T(:,k), S(:,k), press, rho(:,k), 1, nx, eos, & - scale=US%kg_m3_to_R, pres_scale=US%RL2_T2_to_Pa) + call calculate_density(T(:,k), S(:,k), press, rho(:,k), 1, nx, eos, US=US) call calculate_density_derivs(T(:,k), S(:,k), press, drho_dT(:,k), drho_dS(:,k), 1, nx, & - eos, scale=US%kg_m3_to_R, pres_scale=US%RL2_T2_to_Pa) + eos, US=US) enddo do k=k_start,nz ; do i=1,nx ! if (abs(rho(i,k)-R_tgt(k))>tol_rho .and. hin(i,k)>h_massless .and. abs(T(i,k)-land_fill) < epsln ) then diff --git a/src/user/DOME_initialization.F90 b/src/user/DOME_initialization.F90 index 4dfa145746..315e56051c 100644 --- a/src/user/DOME_initialization.F90 +++ b/src/user/DOME_initialization.F90 @@ -359,17 +359,13 @@ subroutine DOME_set_OBC_data(OBC, tv, G, GV, US, param_file, tr_Reg) ! target density and a salinity of 35 psu. This code is taken from ! USER_initialize_temp_sal. pres(:) = tv%P_Ref ; S0(:) = 35.0 ; T0(1) = 25.0 - call calculate_density(T0(1), S0(1), pres(1), rho_guess(1), tv%eqn_of_state, & - scale=US%kg_m3_to_R, pres_scale=US%RL2_T2_to_Pa) - call calculate_density_derivs(T0, S0, pres, drho_dT, drho_dS, 1, 1, tv%eqn_of_state, & - scale=US%kg_m3_to_R, pres_scale=US%RL2_T2_to_Pa) + call calculate_density(T0(1), S0(1), pres(1), rho_guess(1), tv%eqn_of_state, US=US) + call calculate_density_derivs(T0, S0, pres, drho_dT, drho_dS, 1, 1, tv%eqn_of_state, US=US) do k=1,nz ; T0(k) = T0(1) + (GV%Rlay(k)-rho_guess(1)) / drho_dT(1) ; enddo do itt=1,6 - call calculate_density(T0, S0, pres, rho_guess, 1, nz, tv%eqn_of_state, & - scale=US%kg_m3_to_R, pres_scale=US%RL2_T2_to_Pa) - call calculate_density_derivs(T0, S0, pres, drho_dT, drho_dS, 1, nz, tv%eqn_of_state, & - scale=US%kg_m3_to_R, pres_scale=US%RL2_T2_to_Pa) + call calculate_density(T0, S0, pres, rho_guess, 1, nz, tv%eqn_of_state, US=US) + call calculate_density_derivs(T0, S0, pres, drho_dT, drho_dS, 1, nz, tv%eqn_of_state, US=US) do k=1,nz ; T0(k) = T0(k) + (GV%Rlay(k)-rho_guess(k)) / drho_dT(k) ; enddo enddo diff --git a/src/user/benchmark_initialization.F90 b/src/user/benchmark_initialization.F90 index a173150b9d..766474b364 100644 --- a/src/user/benchmark_initialization.F90 +++ b/src/user/benchmark_initialization.F90 @@ -152,10 +152,8 @@ subroutine benchmark_initialize_thickness(h, G, GV, US, param_file, eqn_of_state pres(k) = P_Ref ; S0(k) = 35.0 enddo T0(k1) = 29.0 - call calculate_density(T0(k1), S0(k1), pres(k1), rho_guess(k1), eqn_of_state, & - scale=US%kg_m3_to_R, pres_scale=US%RL2_T2_to_Pa) - call calculate_density_derivs(T0, S0, pres, drho_dT, drho_dS, k1, 1, eqn_of_state, & - scale=US%kg_m3_to_R, pres_scale=US%RL2_T2_to_Pa) + call calculate_density(T0(k1), S0(k1), pres(k1), rho_guess(k1), eqn_of_state, US=US) + call calculate_density_derivs(T0, S0, pres, drho_dT, drho_dS, k1, 1, eqn_of_state, US=US) ! A first guess of the layers' temperatures. do k=1,nz @@ -164,10 +162,8 @@ subroutine benchmark_initialize_thickness(h, G, GV, US, param_file, eqn_of_state ! Refine the guesses for each layer. do itt=1,6 - call calculate_density(T0, S0, pres, rho_guess, 1, nz, eqn_of_state, & - scale=US%kg_m3_to_R, pres_scale=US%RL2_T2_to_Pa) - call calculate_density_derivs(T0, S0, pres, drho_dT, drho_dS, 1, nz, eqn_of_state, & - scale=US%kg_m3_to_R, pres_scale=US%RL2_T2_to_Pa) + call calculate_density(T0, S0, pres, rho_guess, 1, nz, eqn_of_state, US=US) + call calculate_density_derivs(T0, S0, pres, drho_dT, drho_dS, 1, nz, eqn_of_state, US=US) do k=1,nz T0(k) = T0(k) + (GV%Rlay(k) - rho_guess(k)) / drho_dT(k) enddo @@ -261,10 +257,8 @@ subroutine benchmark_init_temperature_salinity(T, S, G, GV, US, param_file, & enddo T0(k1) = 29.0 - call calculate_density(T0(k1), S0(k1), pres(k1), rho_guess(k1), eqn_of_state, & - scale=US%kg_m3_to_R, pres_scale=US%RL2_T2_to_Pa) - call calculate_density_derivs(T0, S0, pres, drho_dT, drho_dS, k1, 1, eqn_of_state, & - scale=US%kg_m3_to_R, pres_scale=US%RL2_T2_to_Pa) + call calculate_density(T0(k1), S0(k1), pres(k1), rho_guess(k1), eqn_of_state, US=US) + call calculate_density_derivs(T0, S0, pres, drho_dT, drho_dS, k1, 1, eqn_of_state, US=US) ! A first guess of the layers' temperatures. ! do k=1,nz @@ -273,10 +267,8 @@ subroutine benchmark_init_temperature_salinity(T, S, G, GV, US, param_file, & ! Refine the guesses for each layer. ! do itt = 1,6 - call calculate_density(T0,S0,pres,rho_guess,1,nz,eqn_of_state, & - scale=US%kg_m3_to_R, pres_scale=US%RL2_T2_to_Pa) - call calculate_density_derivs(T0,S0,pres,drho_dT,drho_dS,1,nz,eqn_of_state, & - scale=US%kg_m3_to_R, pres_scale=US%RL2_T2_to_Pa) + call calculate_density(T0, S0, pres, rho_guess, 1, nz, eqn_of_state, US=US) + call calculate_density_derivs(T0, S0, pres, drho_dT, drho_dS, 1, nz, eqn_of_state, US=US) do k=1,nz T0(k) = T0(k) + (GV%Rlay(k) - rho_guess(k)) / drho_dT(k) enddo From 0a2bb505fd0988371f7f7b6b9739ddd75ea33d3e Mon Sep 17 00:00:00 2001 From: alperaltuntas Date: Sun, 12 Apr 2020 17:42:31 -0600 Subject: [PATCH 168/316] uncomment omp directive for KPP_compute_BLD --- .../vertical/MOM_CVMix_KPP.F90 | 20 +++++++++---------- 1 file changed, 10 insertions(+), 10 deletions(-) diff --git a/src/parameterizations/vertical/MOM_CVMix_KPP.F90 b/src/parameterizations/vertical/MOM_CVMix_KPP.F90 index 5ed9e2a7a4..8c9c2b0e06 100644 --- a/src/parameterizations/vertical/MOM_CVMix_KPP.F90 +++ b/src/parameterizations/vertical/MOM_CVMix_KPP.F90 @@ -962,16 +962,16 @@ subroutine KPP_compute_BLD(CS, G, GV, US, h, Temp, Salt, u, v, EOS, uStar, buoyF buoy_scale = US%L_to_m**2*US%s_to_T**3 ! loop over horizontal points on processor - !GOMP parallel do default(none) private(surfFricVel, iFaceHeight, hcorr, dh, cellHeight, & - !GOMP surfBuoyFlux, U_H, V_H, u, v, Coriolis, pRef, SLdepth_0d, & - !GOMP ksfc, surfHtemp, surfHsalt, surfHu, surfHv, surfHuS, & - !GOMP surfHvS, hTot, delH, surftemp, surfsalt, surfu, surfv, & - !GOMP surfUs, surfVs, Uk, Vk, deltaU2, km1, kk, pres_1D, & - !GOMP Temp_1D, salt_1D, surfBuoyFlux2, MLD_GUESS, LA, rho_1D, & - !GOMP deltarho, N2_1d, ws_1d, LangEnhVT2, enhvt2, wst, & - !GOMP BulkRi_1d, zBottomMinusOffset) & - !GOMP shared(G, GV, CS, US, uStar, h, buoy_scale, buoyFlux, & - !GOMP Temp, Salt, waves, EOS, GoRho) + !$OMP parallel do default(none) private(surfFricVel, iFaceHeight, hcorr, dh, cellHeight, & + !$OMP surfBuoyFlux, U_H, V_H, Coriolis, pRef, SLdepth_0d, & + !$OMP ksfc, surfHtemp, surfHsalt, surfHu, surfHv, surfHuS, & + !$OMP surfHvS, hTot, delH, surftemp, surfsalt, surfu, surfv, & + !$OMP surfUs, surfVs, Uk, Vk, deltaU2, km1, kk, pres_1D, & + !$OMP Temp_1D, salt_1D, surfBuoyFlux2, MLD_GUESS, LA, rho_1D, & + !$OMP deltarho, N2_1d, ws_1d, LangEnhVT2, enhvt2, wst, & + !$OMP BulkRi_1d, zBottomMinusOffset) & + !$OMP shared(G, GV, CS, US, uStar, h, buoy_scale, buoyFlux, & + !$OMP Temp, Salt, waves, EOS, GoRho, u, v) do j = G%jsc, G%jec do i = G%isc, G%iec From 01f7c452e0808719dcebd7fb180024b83e1b80e8 Mon Sep 17 00:00:00 2001 From: alperaltuntas Date: Sun, 12 Apr 2020 21:31:58 -0600 Subject: [PATCH 169/316] uncomment omp in barotropic solver --- src/core/MOM_barotropic.F90 | 108 ++++++++++++++++++------------------ 1 file changed, 54 insertions(+), 54 deletions(-) diff --git a/src/core/MOM_barotropic.F90 b/src/core/MOM_barotropic.F90 index 14fc918b60..d3dabd2147 100644 --- a/src/core/MOM_barotropic.F90 +++ b/src/core/MOM_barotropic.F90 @@ -1584,24 +1584,24 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, call find_face_areas(Datu, Datv, G, GV, US, CS, MS, eta, 1+iev-ie) endif - !GOMP parallel default(shared) + !$OMP parallel default(shared) if (CS%dynamic_psurf .or. .not.project_velocity) then if (use_BT_cont) then - !GOMP do + !$OMP do do j=jsv-1,jev+1 ; do I=isv-2,iev+1 uhbt(I,j) = find_uhbt(ubt(I,j), BTCL_u(I,j), US) + uhbt0(I,j) enddo ; enddo - !GOMP do + !$OMP do do J=jsv-2,jev+1 ; do i=isv-1,iev+1 vhbt(i,J) = find_vhbt(vbt(i,J), BTCL_v(i,J), US) + vhbt0(i,J) enddo ; enddo - !GOMP do + !$OMP do do j=jsv-1,jev+1 ; do i=isv-1,iev+1 eta_pred(i,j) = (eta(i,j) + eta_src(i,j)) + (dtbt * CS%IareaT(i,j)) * & ((uhbt(I-1,j) - uhbt(I,j)) + (vhbt(i,J-1) - vhbt(i,J))) enddo ; enddo else - !GOMP do + !$OMP do do j=jsv-1,jev+1 ; do i=isv-1,iev+1 eta_pred(i,j) = (eta(i,j) + eta_src(i,j)) + (dtbt * CS%IareaT(i,j)) * & (((Datu(I-1,j)*ubt(I-1,j) + uhbt0(I-1,j)) - & @@ -1612,7 +1612,7 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, endif if (CS%dynamic_psurf) then - !GOMP do + !$OMP 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)) enddo ; enddo @@ -1623,7 +1623,7 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, ! eta_PF_BT => eta_pred ; if (project_velocity) eta_PF_BT => eta if (find_etaav) then - !GOMP do + !$OMP do do j=js,je ; do i=is,ie eta_sum(i,j) = eta_sum(i,j) + wt_accel2(n) * eta_PF_BT(i,j) enddo ; enddo @@ -1631,23 +1631,23 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, if (interp_eta_PF) then wt_end = n*Instep ! This could be (n-0.5)*Instep. - !GOMP do + !$OMP do do j=jsv-1,jev+1 ; do i=isv-1,iev+1 eta_PF(i,j) = eta_PF_1(i,j) + wt_end*d_eta_PF(i,j) enddo ; enddo endif if (apply_OBC_flather .or. apply_OBC_open) then - !GOMP do + !$OMP do do j=jsv,jev ; do I=isv-2,iev+1 ubt_old(I,j) = ubt(I,j) enddo ; enddo - !GOMP do + !$OMP do do J=jsv-2,jev+1 ; do i=isv,iev vbt_old(i,J) = vbt(i,J) enddo ; enddo endif - !GOMP end parallel + !$OMP end parallel if (apply_OBCs) then if (MOD(n+G%first_direction,2)==1) then @@ -1657,7 +1657,7 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, endif if (CS%BT_OBC%apply_u_OBCs) then ! save the old value of ubt and uhbt - !GOMP parallel do default(shared) + !$OMP parallel do default(shared) do J=jsv-joff,jev+joff ; do i=isv-1,iev ubt_prev(i,J) = ubt(i,J) ; uhbt_prev(i,J) = uhbt(i,J) ubt_sum_prev(i,J) = ubt_sum(i,J) ; uhbt_sum_prev(i,J) = uhbt_sum(i,J) ; ubt_wtd_prev(i,J) = ubt_wtd(i,J) @@ -1665,7 +1665,7 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, endif if (CS%BT_OBC%apply_v_OBCs) then ! save the old value of vbt and vhbt - !GOMP parallel do default(shared) + !$OMP parallel do default(shared) do J=jsv-1,jev ; do i=isv-ioff,iev+ioff vbt_prev(i,J) = vbt(i,J) ; vhbt_prev(i,J) = vhbt(i,J) vbt_sum_prev(i,J) = vbt_sum(i,J) ; vhbt_sum_prev(i,J) = vhbt_sum(i,J) ; vbt_wtd_prev(i,J) = vbt_wtd(i,J) @@ -1673,10 +1673,10 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, endif endif - !GOMP parallel default(shared) private(vel_prev) + !$OMP parallel default(shared) private(vel_prev) if (MOD(n+G%first_direction,2)==1) then ! On odd-steps, update v first. - !GOMP do + !$OMP do do J=jsv-1,jev ; do i=isv-1,iev+1 Cor_v(i,J) = -1.0*((amer(I-1,j) * ubt(I-1,j) + cmer(I,j+1) * ubt(I,j+1)) + & (bmer(I,j) * ubt(I,j) + dmer(I-1,j+1) * ubt(I-1,j+1))) - Cor_ref_v(i,J) @@ -1685,19 +1685,19 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, dgeo_de * CS%IdyCv(i,J) enddo ; enddo if (CS%dynamic_psurf) then - !GOMP do + !$OMP do do J=jsv-1,jev ; do i=isv-1,iev+1 PFv(i,J) = PFv(i,J) + (p_surf_dyn(i,j) - p_surf_dyn(i,j+1)) * CS%IdyCv(i,J) enddo ; enddo endif if (CS%BT_OBC%apply_v_OBCs) then ! zero out PF across boundary - !GOMP do + !$OMP do do J=jsv-1,jev ; do i=isv-1,iev+1 ; if (OBC%segnum_v(i,J) /= OBC_NONE) then PFv(i,J) = 0.0 endif ; enddo ; enddo endif - !GOMP do + !$OMP do do J=jsv-1,jev ; do i=isv-1,iev+1 vel_prev = vbt(i,J) vbt(i,J) = bt_rem_v(i,J) * (vbt(i,J) + & @@ -1713,24 +1713,24 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, enddo ; enddo if (use_BT_cont) then - !GOMP do + !$OMP do do J=jsv-1,jev ; do i=isv-1,iev+1 vhbt(i,J) = find_vhbt(vbt_trans(i,J), BTCL_v(i,J), US) + vhbt0(i,J) enddo ; enddo else - !GOMP do + !$OMP do do J=jsv-1,jev ; do i=isv-1,iev+1 vhbt(i,J) = Datv(i,J)*vbt_trans(i,J) + vhbt0(i,J) enddo ; enddo endif if (CS%BT_OBC%apply_v_OBCs) then ! copy back the value for v-points on the boundary. - !GOMP do + !$OMP do do J=jsv-1,jev ; do i=isv-1,iev+1 ; if (OBC%segnum_v(i,J) /= OBC_NONE) then vbt(i,J) = vbt_prev(i,J) ; vhbt(i,J) = vhbt_prev(i,J) endif ; enddo ; enddo endif ! Now update the zonal velocity. - !GOMP do + !$OMP do do j=jsv,jev ; do I=isv-1,iev Cor_u(I,j) = ((azon(I,j) * vbt(i+1,J) + czon(I,j) * vbt(i,J-1)) + & (bzon(I,j) * vbt(i,J) + dzon(I,j) * vbt(i+1,J-1))) - & @@ -1741,19 +1741,19 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, enddo ; enddo if (CS%dynamic_psurf) then - !GOMP do + !$OMP do do j=jsv,jev ; do I=isv-1,iev PFu(I,j) = PFu(I,j) + (p_surf_dyn(i,j) - p_surf_dyn(i+1,j)) * CS%IdxCu(I,j) enddo ; enddo endif if (CS%BT_OBC%apply_u_OBCs) then ! zero out pressure force across boundary - !GOMP do + !$OMP do do j=jsv,jev ; do I=isv-1,iev ; if (OBC%segnum_u(I,j) /= OBC_NONE) then PFu(I,j) = 0.0 endif ; enddo ; enddo endif - !GOMP do + !$OMP do do j=jsv,jev ; do I=isv-1,iev vel_prev = ubt(I,j) ubt(I,j) = bt_rem_u(I,j) * (ubt(I,j) + & @@ -1770,25 +1770,25 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, enddo ; enddo if (use_BT_cont) then - !GOMP do + !$OMP do do j=jsv,jev ; do I=isv-1,iev uhbt(I,j) = find_uhbt(ubt_trans(I,j), BTCL_u(I,j), US) + uhbt0(I,j) enddo ; enddo else - !GOMP do + !$OMP do do j=jsv,jev ; do I=isv-1,iev uhbt(I,j) = Datu(I,j)*ubt_trans(I,j) + uhbt0(I,j) enddo ; enddo endif if (CS%BT_OBC%apply_u_OBCs) then ! copy back the value for u-points on the boundary. - !GOMP do + !$OMP do do j=jsv,jev ; do I=isv-1,iev ; if (OBC%segnum_u(I,j) /= OBC_NONE) then ubt(I,j) = ubt_prev(I,j); uhbt(I,j) = uhbt_prev(I,j) endif ; enddo ; enddo endif else ! On even steps, update u first. - !GOMP do + !$OMP do do j=jsv-1,jev+1 ; do I=isv-1,iev Cor_u(I,j) = ((azon(I,j) * vbt(i+1,J) + czon(I,j) * vbt(i,J-1)) + & (bzon(I,j) * vbt(i,J) + dzon(I,j) * vbt(i+1,J-1))) - & @@ -1799,20 +1799,20 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, enddo ; enddo if (CS%dynamic_psurf) then - !GOMP do + !$OMP do do j=jsv-1,jev+1 ; do I=isv-1,iev PFu(I,j) = PFu(I,j) + (p_surf_dyn(i,j) - p_surf_dyn(i+1,j)) * CS%IdxCu(I,j) enddo ; enddo endif if (CS%BT_OBC%apply_u_OBCs) then ! zero out pressure force across boundary - !GOMP do + !$OMP do do j=jsv,jev ; do I=isv-1,iev ; if (OBC%segnum_u(I,j) /= OBC_NONE) then PFu(I,j) = 0.0 endif ; enddo ; enddo endif - !GOMP do + !$OMP do do j=jsv-1,jev+1 ; do I=isv-1,iev vel_prev = ubt(I,j) ubt(I,j) = bt_rem_u(I,j) * (ubt(I,j) + & @@ -1829,18 +1829,18 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, enddo ; enddo if (use_BT_cont) then - !GOMP do + !$OMP do do j=jsv-1,jev+1 ; do I=isv-1,iev uhbt(I,j) = find_uhbt(ubt_trans(I,j), BTCL_u(I,j), US) + uhbt0(I,j) enddo ; enddo else - !GOMP do + !$OMP do do j=jsv-1,jev+1 ; do I=isv-1,iev uhbt(I,j) = Datu(I,j)*ubt_trans(I,j) + uhbt0(I,j) enddo ; enddo endif if (CS%BT_OBC%apply_u_OBCs) then ! copy back the value for u-points on the boundary. - !GOMP do + !$OMP do do j=jsv-1,jev+1 ; do I=isv-1,iev ; if (OBC%segnum_u(I,j) /= OBC_NONE) then ubt(I,j) = ubt_prev(I,j); uhbt(I,j) = uhbt_prev(I,j) endif ; enddo ; enddo @@ -1848,7 +1848,7 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, ! Now update the meridional velocity. if (CS%use_old_coriolis_bracket_bug) then - !GOMP do + !$OMP do do J=jsv-1,jev ; do i=isv,iev Cor_v(i,J) = -1.0*((amer(I-1,j) * ubt(I-1,j) + bmer(I,j) * ubt(I,j)) + & (cmer(I,j+1) * ubt(I,j+1) + dmer(I-1,j+1) * ubt(I-1,j+1))) - Cor_ref_v(i,J) @@ -1857,7 +1857,7 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, dgeo_de * CS%IdyCv(i,J) enddo ; enddo else - !GOMP do + !$OMP do do J=jsv-1,jev ; do i=isv,iev Cor_v(i,J) = -1.0*((amer(I-1,j) * ubt(I-1,j) + cmer(I,j+1) * ubt(I,j+1)) + & (bmer(I,j) * ubt(I,j) + dmer(I-1,j+1) * ubt(I-1,j+1))) - Cor_ref_v(i,J) @@ -1868,20 +1868,20 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, endif if (CS%dynamic_psurf) then - !GOMP do + !$OMP do do J=jsv-1,jev ; do i=isv,iev PFv(i,J) = PFv(i,J) + (p_surf_dyn(i,j) - p_surf_dyn(i,j+1)) * CS%IdyCv(i,J) enddo ; enddo endif if (CS%BT_OBC%apply_v_OBCs) then ! zero out PF across boundary - !GOMP do + !$OMP do do J=jsv-1,jev ; do i=isv-1,iev+1 ; if (OBC%segnum_v(i,J) /= OBC_NONE) then PFv(i,J) = 0.0 endif ; enddo ; enddo endif - !GOMP do + !$OMP do do J=jsv-1,jev ; do i=isv,iev vel_prev = vbt(i,J) vbt(i,J) = bt_rem_v(i,J) * (vbt(i,J) + & @@ -1897,64 +1897,64 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, endif enddo ; enddo if (use_BT_cont) then - !GOMP do + !$OMP do do J=jsv-1,jev ; do i=isv,iev vhbt(i,J) = find_vhbt(vbt_trans(i,J), BTCL_v(i,J), US) + vhbt0(i,J) enddo ; enddo else - !GOMP do + !$OMP do do J=jsv-1,jev ; do i=isv,iev vhbt(i,J) = Datv(i,J)*vbt_trans(i,J) + vhbt0(i,J) enddo ; enddo endif if (CS%BT_OBC%apply_v_OBCs) then ! copy back the value for v-points on the boundary. - !GOMP do + !$OMP do do J=jsv-1,jev ; do i=isv,iev ; if (OBC%segnum_v(i,J) /= OBC_NONE) then vbt(i,J) = vbt_prev(i,J); vhbt(i,J) = vhbt_prev(i,J) endif ; enddo ; enddo endif endif - !GOMP end parallel + !$OMP end parallel - !GOMP parallel default(shared) + !$OMP parallel default(shared) if (find_PF) then - !GOMP do + !$OMP do do j=js,je ; do I=is-1,ie PFu_bt_sum(I,j) = PFu_bt_sum(I,j) + wt_accel2(n) * PFu(I,j) enddo ; enddo - !GOMP do + !$OMP do do J=js-1,je ; do i=is,ie PFv_bt_sum(i,J) = PFv_bt_sum(i,J) + wt_accel2(n) * PFv(i,J) enddo ; enddo endif if (find_Cor) then - !GOMP do + !$OMP do do j=js,je ; do I=is-1,ie Coru_bt_sum(I,j) = Coru_bt_sum(I,j) + wt_accel2(n) * Cor_u(I,j) enddo ; enddo - !GOMP do + !$OMP do do J=js-1,je ; do i=is,ie Corv_bt_sum(i,J) = Corv_bt_sum(i,J) + wt_accel2(n) * Cor_v(i,J) enddo ; enddo endif - !GOMP do + !$OMP do do j=js,je ; do I=is-1,ie ubt_sum(I,j) = ubt_sum(I,j) + wt_trans(n) * ubt_trans(I,j) uhbt_sum(I,j) = uhbt_sum(I,j) + wt_trans(n) * uhbt(I,j) ubt_wtd(I,j) = ubt_wtd(I,j) + wt_vel(n) * ubt(I,j) enddo ; enddo - !GOMP do + !$OMP do do J=js-1,je ; do i=is,ie vbt_sum(i,J) = vbt_sum(i,J) + wt_trans(n) * vbt_trans(i,J) vhbt_sum(i,J) = vhbt_sum(i,J) + wt_trans(n) * vhbt(i,J) vbt_wtd(i,J) = vbt_wtd(i,J) + wt_vel(n) * vbt(i,J) enddo ; enddo - !GOMP end parallel + !$OMP end parallel if (apply_OBCs) then if (CS%BT_OBC%apply_u_OBCs) then ! copy back the value for u-points on the boundary. - !GOMP parallel do default(shared) + !$OMP parallel do default(shared) do j=js,je ; do I=is-1,ie if (OBC%segnum_u(I,j) /= OBC_NONE) then ubt_sum(I,j) = ubt_sum_prev(I,j) ; uhbt_sum(I,j) = uhbt_sum_prev(I,j) @@ -1964,7 +1964,7 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, endif if (CS%BT_OBC%apply_v_OBCs) then ! copy back the value for v-points on the boundary. - !GOMP parallel do default(shared) + !$OMP parallel do default(shared) do J=js-1,je ; do I=is,ie if (OBC%segnum_v(i,J) /= OBC_NONE) then vbt_sum(i,J) = vbt_sum_prev(i,J) ; vhbt_sum(i,J) = vhbt_sum_prev(i,J) From 1e8c50166b6185f65c9ffcbbe58720add0c8bf19 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Mon, 13 Apr 2020 06:44:28 -0400 Subject: [PATCH 170/316] Corrected pressure units in comments Corrected pressure unit documentation in comments in 5 files. Also fixed punctuation in comments in MOM_EOS.F90. All answers are bitwise identical. --- src/core/MOM_PressureForce_analytic_FV.F90 | 4 +- src/core/MOM_PressureForce_blocked_AFV.F90 | 6 +- src/equation_of_state/MOM_EOS.F90 | 340 +++++++++--------- .../vertical/MOM_bulk_mixed_layer.F90 | 2 +- .../vertical/MOM_vert_friction.F90 | 4 +- 5 files changed, 178 insertions(+), 178 deletions(-) diff --git a/src/core/MOM_PressureForce_analytic_FV.F90 b/src/core/MOM_PressureForce_analytic_FV.F90 index ca6f7ae283..4f85980f00 100644 --- a/src/core/MOM_PressureForce_analytic_FV.F90 +++ b/src/core/MOM_PressureForce_analytic_FV.F90 @@ -172,7 +172,7 @@ subroutine PressureForce_AFV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p real :: alpha_ref ! A reference specific volume [R-1 ~> m3 kg-1] that is used ! to reduce the impact of truncation errors. real :: rho_in_situ(SZI_(G)) ! The in situ density [R ~> kg m-3]. - real :: Pa_to_H ! A factor to convert from Pa to the thicknesss units (H) [H T2 R-1 L-12 ~> H Pa-1]. + real :: Pa_to_H ! A factor to convert from Pa to the thicknesss units (H) [H T2 R-1 L-2 ~> H Pa-1]. real :: H_to_RL2_T2 ! A factor to convert from thicknesss units (H) to pressure units [R L2 T-2 H-1 ~> Pa H-1]. ! real :: oneatm = 101325.0 ! 1 atm in [Pa] = [kg m-1 s-2] real, parameter :: C1_6 = 1.0/6.0 @@ -490,7 +490,7 @@ subroutine PressureForce_AFV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_at real :: rho_in_situ(SZI_(G)) ! The in situ density [R ~> kg m-3]. real :: p_ref(SZI_(G)) ! The pressure used to calculate the coordinate ! density, [R L2 T-2 ~> Pa] (usually 2e7 Pa = 2000 dbar). - real :: p0(SZI_(G)) ! An array of zeros to use for pressure [Pa]. + real :: p0(SZI_(G)) ! An array of zeros to use for pressure [R L2 T-2 ~> Pa]. real :: h_neglect ! A thickness that is so small it is usually lost ! in roundoff and can be neglected [H ~> m]. real :: I_Rho0 ! The inverse of the Boussinesq reference density [R-1 ~> m3 kg-1]. diff --git a/src/core/MOM_PressureForce_blocked_AFV.F90 b/src/core/MOM_PressureForce_blocked_AFV.F90 index 9d1c12f381..d618060951 100644 --- a/src/core/MOM_PressureForce_blocked_AFV.F90 +++ b/src/core/MOM_PressureForce_blocked_AFV.F90 @@ -158,7 +158,7 @@ subroutine PressureForce_blk_AFV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, ! density [R L2 T-2 ~> 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 [Pa]. + ! in roundoff and can be neglected [R L2 T-2 ~> Pa]. real :: I_gEarth ! The inverse of GV%g_Earth [L2 Z L-2 ~> s2 m-1] real :: alpha_anom ! The in-situ specific volume, averaged over a ! layer, less alpha_ref [R-1 ~> 3 kg-1]. @@ -169,7 +169,7 @@ subroutine PressureForce_blk_AFV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, real :: alpha_ref ! A reference specific volume [R-1 ~> m3 kg-1] that is used ! to reduce the impact of truncation errors. real :: rho_in_situ(SZI_(G)) ! The in situ density [R ~> kg m-3]. - real :: Pa_to_H ! A factor to convert from Pa to the thicknesss units (H) [H T2 R-1 L-12 ~> H Pa-1]. + real :: Pa_to_H ! A factor to convert from Pa to the thicknesss units (H) [H T2 R-1 L-2 ~> H Pa-1]. real :: H_to_RL2_T2 ! A factor to convert from thicknesss units (H) to pressure units [R L2 T-2 H-1 ~> Pa H-1]. ! real :: oneatm = 101325.0 ! 1 atm in [Pa] = [kg m-1 s-2] real, parameter :: C1_6 = 1.0/6.0 @@ -474,7 +474,7 @@ subroutine PressureForce_blk_AFV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, real :: rho_in_situ(SZI_(G)) ! The in situ density [R ~> kg m-3]. real :: p_ref(SZI_(G)) ! The pressure used to calculate the coordinate ! density [R L2 T-2 ~> Pa] (usually 2e7 Pa = 2000 dbar). - real :: p0(SZI_(G)) ! An array of zeros to use for pressure [Pa]. + real :: p0(SZI_(G)) ! An array of zeros to use for pressure [R L2 T-2 ~> Pa]. real :: h_neglect ! A thickness that is so small it is usually lost ! in roundoff and can be neglected [H ~> m or kg m-2]. real :: I_Rho0 ! The inverse of the Boussinesq reference density [R-1 ~> m3 kg-1]. diff --git a/src/equation_of_state/MOM_EOS.F90 b/src/equation_of_state/MOM_EOS.F90 index 2c518f5af1..e4da6df2bc 100644 --- a/src/equation_of_state/MOM_EOS.F90 +++ b/src/equation_of_state/MOM_EOS.F90 @@ -102,14 +102,14 @@ module MOM_EOS !! code for the integrals of density. logical :: Compressible = .true. !< If true, in situ density is a function of pressure. ! The following parameters are used with the linear equation of state only. - real :: Rho_T0_S0 !< The density at T=0, S=0 [kg m-3]. + real :: Rho_T0_S0 !< The density at T=0, S=0 [kg m-3] real :: dRho_dT !< The partial derivative of density with temperature [kg m-3 degC-1] - real :: dRho_dS !< The partial derivative of density with salinity [kg m-3 ppt-1]. + real :: dRho_dS !< The partial derivative of density with salinity [kg m-3 ppt-1] ! The following parameters are use with the linear expression for the freezing ! point only. - real :: TFr_S0_P0 !< The freezing potential temperature at S=0, P=0 [degC]. - real :: dTFr_dS !< The derivative of freezing point with salinity [degC ppt-1]. - real :: dTFr_dp !< The derivative of freezing point with pressure [degC Pa-1]. + real :: TFr_S0_P0 !< The freezing potential temperature at S=0, P=0 [degC] + real :: dTFr_dS !< The derivative of freezing point with salinity [degC ppt-1] + real :: dTFr_dp !< The derivative of freezing point with pressure [degC Pa-1] ! logical :: test_EOS = .true. ! If true, test the equation of state end type EOS_type @@ -149,13 +149,13 @@ subroutine calculate_density_scalar(T, S, pressure, rho, EOS, rho_ref, US, scale real, intent(in) :: pressure !< Pressure [Pa] or [R L2 T-2 ~> Pa] real, intent(out) :: rho !< Density (in-situ if pressure is local) [kg m-3] or [R ~> kg m-3] type(EOS_type), pointer :: EOS !< Equation of state structure - real, optional, intent(in) :: rho_ref !< A reference density [kg m-3]. + real, optional, intent(in) :: rho_ref !< A reference density [kg m-3] type(unit_scale_type), optional, intent(in) :: US !< A dimensional unit scaling type real, optional, intent(in) :: scale !< A multiplicative factor by which to scale density in !! combination with scaling given by US [various] real :: rho_scale ! A factor to convert density from kg m-3 to the desired units [R m3 kg-1 ~> 1] - real :: p_scale ! A factor to convert pressure to units of Pa. + real :: p_scale ! A factor to convert pressure to units of Pa [Pa T2 R-1 L-2 ~> 1] if (.not.associated(EOS)) call MOM_error(FATAL, & "calculate_density_scalar called with an unassociated EOS_type EOS.") @@ -191,17 +191,17 @@ end subroutine calculate_density_scalar subroutine calculate_density_array(T, S, pressure, rho, start, npts, EOS, rho_ref, US, scale) real, dimension(:), intent(in) :: T !< Potential temperature referenced to the surface [degC] real, dimension(:), intent(in) :: S !< Salinity [ppt] - real, dimension(:), intent(in) :: pressure !< Pressure [Pa] or [other ~> Pa] + real, dimension(:), intent(in) :: pressure !< Pressure [Pa] or [R L2 T-2 ~> Pa] real, dimension(:), intent(inout) :: rho !< Density (in-situ if pressure is local) [kg m-3] or [R ~> kg m-3] 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 [kg m-3]. + real, optional, intent(in) :: rho_ref !< A reference density [kg m-3] type(unit_scale_type), optional, intent(in) :: US !< A dimensional unit scaling type real, optional, intent(in) :: scale !< A multiplicative factor by which to scale density !! in combination with scaling given by US [various] - real :: p_scale ! A factor to convert pressure to units of Pa. + real :: p_scale ! A factor to convert pressure to units of Pa [Pa T2 R-1 L-2 ~> 1] real :: rho_scale ! A factor to convert density from kg m-3 to the desired units [R m3 kg-1 ~> 1] real, dimension(size(pressure)) :: pres ! Pressure converted to [Pa] integer :: j @@ -329,12 +329,12 @@ subroutine calculate_spec_vol_scalar(T, S, pressure, specvol, EOS, spv_ref, US, real, intent(in) :: pressure !< Pressure [Pa] or [R L2 T-2 ~> Pa] real, intent(out) :: specvol !< In situ? specific volume [m3 kg-1] or [R-1 ~> m3 kg-1] type(EOS_type), pointer :: EOS !< Equation of state structure - real, optional, intent(in) :: spv_ref !< A reference specific volume [m3 kg-1]. + real, optional, intent(in) :: spv_ref !< A reference specific volume [m3 kg-1] type(unit_scale_type), optional, intent(in) :: US !< A dimensional unit scaling type real, optional, intent(in) :: scale !< A multiplicative factor by which to scale specific !! volume in combination with scaling given by US [various] - real :: p_scale ! A factor to convert pressure to units of Pa. + real :: p_scale ! A factor to convert pressure to units of Pa [Pa T2 R-1 L-2 ~> 1] real :: rho ! Density [kg m-3] real :: spv_scale ! A factor to convert specific volume from m3 kg-1 to the desired units [kg R-1 m-3 ~> 1] @@ -375,21 +375,21 @@ 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, US, scale) - real, dimension(:), intent(in) :: T !< potential temperature relative to the surface [degC]. - real, dimension(:), intent(in) :: S !< salinity [ppt]. - real, dimension(:), intent(in) :: pressure !< pressure [Pa] or [R L2 T-2 ~> Pa]. - real, dimension(:), intent(inout) :: specvol !< in situ specific volume [kg m-3] or [R-1 ~> m3 kg-1]. + real, dimension(:), intent(in) :: T !< potential temperature relative to the surface [degC] + real, dimension(:), intent(in) :: S !< salinity [ppt] + real, dimension(:), intent(in) :: pressure !< pressure [Pa] or [R L2 T-2 ~> Pa] + real, dimension(:), intent(inout) :: specvol !< in situ specific volume [kg m-3] or [R-1 ~> m3 kg-1] 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 [m3 kg-1]. + real, optional, intent(in) :: spv_ref !< A reference specific volume [m3 kg-1] type(unit_scale_type), optional, intent(in) :: US !< A dimensional unit scaling type real, optional, intent(in) :: scale !< A multiplicative factor by which to scale specific !! volume in combination with scaling given by US [various] real, dimension(size(pressure)) :: pres ! Pressure converted to [Pa] real, dimension(size(specvol)) :: rho ! Density [kg m-3] - real :: p_scale ! A factor to convert pressure to units of Pa. + real :: p_scale ! A factor to convert pressure to units of Pa [Pa T2 R-1 L-2 ~> 1] real :: spv_scale ! A factor to convert specific volume from m3 kg-1 to the desired units [kg R-1 m-3 ~> 1] integer :: j @@ -462,7 +462,7 @@ subroutine calculate_spec_vol_HI_1d(T, S, pressure, specvol, HI, EOS, US, halo, type(EOS_type), pointer :: EOS !< Equation of state structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type integer, optional, intent(in) :: halo !< The halo size to work on; missing is equivalent to 0. - real, optional, intent(in) :: spv_ref !< A reference specific volume [R-1 ~> m3 kg-1]. + real, optional, intent(in) :: spv_ref !< A reference specific volume [R-1 ~> m3 kg-1] ! Local variables real, dimension(HI%isd:HI%ied) :: pres ! Pressure converted to [Pa] @@ -549,11 +549,11 @@ end subroutine calculate_spec_vol_HI_1d !> Calls the appropriate subroutine to calculate the freezing point for scalar inputs. subroutine calculate_TFreeze_scalar(S, pressure, T_fr, EOS, pres_scale) real, intent(in) :: S !< Salinity [ppt] - real, intent(in) :: pressure !< Pressure [Pa] + real, intent(in) :: pressure !< Pressure [Pa] or [other] real, intent(out) :: T_fr !< Freezing point potential temperature referenced !! to the surface [degC] type(EOS_type), pointer :: EOS !< Equation of state structure - real, optional, intent(in) :: pres_scale !< A multiplicative factor to convert pressure into Pa. + real, optional, intent(in) :: pres_scale !< A multiplicative factor to convert pressure into Pa ! Local variables real :: p_scale ! A factor to convert pressure to units of Pa. @@ -580,7 +580,7 @@ end subroutine calculate_TFreeze_scalar !> Calls the appropriate subroutine to calculate the freezing point for a 1-D array. subroutine calculate_TFreeze_array(S, pressure, T_fr, start, npts, EOS, pres_scale) real, dimension(:), intent(in) :: S !< Salinity [ppt] - real, dimension(:), intent(in) :: pressure !< Pressure [Pa] + real, dimension(:), intent(in) :: pressure !< Pressure [Pa] or [other] real, dimension(:), intent(inout) :: T_fr !< Freezing point potential temperature referenced !! to the surface [degC] integer, intent(in) :: start !< Starting index within the array @@ -633,9 +633,9 @@ subroutine calculate_density_derivs_array(T, S, pressure, drho_dT, drho_dS, star real, dimension(:), intent(in) :: S !< Salinity [ppt] real, dimension(:), intent(in) :: pressure !< Pressure [Pa] or [R L2 T-2 ~> Pa] real, dimension(:), intent(inout) :: drho_dT !< The partial derivative of density with potential - !! temperature [kg m-3 degC-1] or [R degC-1 ~> kg m-3 degC-1]. + !! temperature [kg m-3 degC-1] or [R degC-1 ~> kg m-3 degC-1] real, dimension(:), intent(inout) :: drho_dS !< The partial derivative of density with salinity, - !! in [kg m-3 ppt-1] or [R degC-1 ~> kg m-3 ppt-1]. + !! in [kg m-3 ppt-1] or [R degC-1 ~> kg m-3 ppt-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 @@ -646,7 +646,7 @@ subroutine calculate_density_derivs_array(T, S, pressure, drho_dT, drho_dS, star ! Local variables real, dimension(size(pressure)) :: pres ! Pressure converted to [Pa] real :: rho_scale ! A factor to convert density from kg m-3 to the desired units [R m3 kg-1 ~> 1] - real :: p_scale ! A factor to convert pressure to units of Pa. + real :: p_scale ! A factor to convert pressure to units of Pa [Pa T2 R-1 L-2 ~> 1] integer :: j if (.not.associated(EOS)) call MOM_error(FATAL, & @@ -778,7 +778,7 @@ subroutine calculate_density_derivs_scalar(T, S, pressure, drho_dT, drho_dS, EOS real, intent(out) :: drho_dT !< The partial derivative of density with potential !! temperature [kg m-3 degC-1] or [R degC-1 ~> kg m-3 degC-1] real, intent(out) :: drho_dS !< The partial derivative of density with salinity, - !! in [kg m-3 ppt-1] or [R ppt-1 ~> kg m-3 ppt-1]. + !! in [kg m-3 ppt-1] or [R ppt-1 ~> kg m-3 ppt-1] type(EOS_type), pointer :: EOS !< Equation of state structure type(unit_scale_type), optional, intent(in) :: US !< A dimensional unit scaling type real, optional, intent(in) :: scale !< A multiplicative factor by which to scale density @@ -786,7 +786,7 @@ subroutine calculate_density_derivs_scalar(T, S, pressure, drho_dT, drho_dS, EOS ! Local variables real :: rho_scale ! A factor to convert density from kg m-3 to the desired units [R m3 kg-1 ~> 1] - real :: p_scale ! A factor to convert pressure to units of Pa. + real :: p_scale ! A factor to convert pressure to units of Pa [Pa T2 R-1 L-2 ~> 1] integer :: j if (.not.associated(EOS)) call MOM_error(FATAL, & @@ -841,8 +841,8 @@ subroutine calculate_density_second_derivs_array(T, S, pressure, drho_dS_dS, drh ! Local variables real, dimension(size(pressure)) :: pres ! Pressure converted to [Pa] real :: rho_scale ! A factor to convert density from kg m-3 to the desired units [R m3 kg-1 ~> 1] - real :: p_scale ! A factor to convert pressure to units of Pa. - real :: I_p_scale ! The inverse of the factor to convert pressure to units of Pa. + real :: p_scale ! A factor to convert pressure to units of Pa [Pa T2 R-1 L-2 ~> 1] + real :: I_p_scale ! The inverse of the factor to convert pressure to units of Pa [R L2 T-2 Pa-1 ~> 1] integer :: j if (.not.associated(EOS)) call MOM_error(FATAL, & @@ -906,7 +906,7 @@ subroutine calculate_density_second_derivs_scalar(T, S, pressure, drho_dS_dS, dr drho_dS_dP, drho_dT_dP, EOS, US, scale) real, intent(in) :: T !< Potential temperature referenced to the surface [degC] real, intent(in) :: S !< Salinity [ppt] - real, intent(in) :: pressure !< Pressure [Pa] + real, intent(in) :: pressure !< Pressure [Pa] or [R L2 T-2 ~> Pa] real, intent(out) :: drho_dS_dS !< Partial derivative of beta with respect to S !! [kg m-3 ppt-2] or [R ppt-2 ~> kg m-3 ppt-2] real, intent(out) :: drho_dS_dT !< Partial derivative of beta with respect to T @@ -923,8 +923,8 @@ subroutine calculate_density_second_derivs_scalar(T, S, pressure, drho_dS_dS, dr !! in combination with scaling given by US [various] ! Local variables real :: rho_scale ! A factor to convert density from kg m-3 to the desired units [R m3 kg-1 ~> 1] - real :: p_scale ! A factor to convert pressure to units of Pa. - real :: I_p_scale ! The inverse of the factor to convert pressure to units of Pa. + real :: p_scale ! A factor to convert pressure to units of Pa [Pa T2 R-1 L-2 ~> 1] + real :: I_p_scale ! The inverse of the factor to convert pressure to units of Pa [R L2 T-2 Pa-1 ~> 1] if (.not.associated(EOS)) call MOM_error(FATAL, & "calculate_density_derivs called with an unassociated EOS_type EOS.") @@ -971,7 +971,7 @@ subroutine calculate_spec_vol_derivs_array(T, S, pressure, dSV_dT, dSV_dS, start real, dimension(:), intent(inout) :: dSV_dT !< The partial derivative of specific volume with potential !! temperature [m3 kg-1 degC-1] or [R-1 degC-1 ~> m3 kg-1 degC-1] real, dimension(:), intent(inout) :: dSV_dS !< The partial derivative of specific volume with salinity - !! [m3 kg-1 ppt-1] or [R-1 ppt-1 ~> m3 kg-1 ppt-1]. + !! [m3 kg-1 ppt-1] or [R-1 ppt-1 ~> m3 kg-1 ppt-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 @@ -984,7 +984,7 @@ subroutine calculate_spec_vol_derivs_array(T, S, pressure, dSV_dT, dSV_dS, start real, dimension(size(T)) :: rho ! In situ density [kg m-3] real, dimension(size(T)) :: dRho_dT ! Derivative of density with temperature [kg m-3 degC-1] real, dimension(size(T)) :: dRho_dS ! Derivative of density with salinity [kg m-3 ppt-1] - real :: p_scale ! A factor to convert pressure to units of Pa. + real :: p_scale ! A factor to convert pressure to units of Pa [Pa T2 R-1 L-2 ~> 1] real :: spv_scale ! A factor to convert specific volume from m3 kg-1 to the desired units [kg R-1 m-3 ~> 1] integer :: j @@ -1066,7 +1066,7 @@ subroutine calculate_spec_vol_derivs_HI_1d(T, S, pressure, dSV_dT, dSV_dS, HI, E real, dimension(HI%isd:HI%ied), intent(inout) :: dSV_dT !< The partial derivative of specific volume with potential !! temperature [R-1 degC-1 ~> m3 kg-1 degC-1] real, dimension(HI%isd:HI%ied), intent(inout) :: dSV_dS !< The partial derivative of specific volume with salinity - !! [R-1 ppt-1 ~> m3 kg-1 ppt-1]. + !! [R-1 ppt-1 ~> m3 kg-1 ppt-1] type(EOS_type), pointer :: EOS !< Equation of state structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type integer, optional, intent(in) :: halo !< The halo size to work on; missing is equivalent to 0. @@ -1156,9 +1156,9 @@ subroutine calculate_compress_array(T, S, pressure, rho, drho_dp, start, npts, E 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(inout) :: rho !< In situ density [kg m-3]. + real, dimension(:), intent(inout) :: rho !< In situ density [kg m-3] real, dimension(:), intent(inout) :: drho_dp !< The partial derivative of density with pressure - !! (also the inverse of the square of sound speed) [s2 m-2]. + !! (also the inverse of the square of sound speed) [s2 m-2] 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 @@ -1192,7 +1192,7 @@ subroutine calculate_compress_scalar(T, S, pressure, rho, drho_dp, EOS) real, intent(in) :: pressure !< Pressure [Pa] real, intent(out) :: rho !< In situ density [kg m-3] real, intent(out) :: drho_dp !< The partial derivative of density with pressure - !! (also the inverse of the square of sound speed) [s2 m-2]. + !! (also the inverse of the square of sound speed) [s2 m-2] type(EOS_type), pointer :: EOS !< Equation of state structure real, dimension(1) :: Ta, Sa, pa, rhoa, drho_dpa @@ -1222,29 +1222,29 @@ subroutine int_specific_vol_dp(T, S, p_t, p_b, alpha_ref, HI, EOS, & real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & intent(in) :: S !< Salinity [ppt] real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & - intent(in) :: p_t !< Pressure at the top of the layer [R L2 T-2 ~> Pa] or [Pa]. + intent(in) :: p_t !< Pressure at the top of the layer [R L2 T-2 ~> Pa] or [Pa] real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & - intent(in) :: p_b !< Pressure at the bottom of the layer [R L2 T-2 ~> Pa] or [Pa]. + intent(in) :: p_b !< Pressure at the bottom of the layer [R L2 T-2 ~> Pa] or [Pa] real, intent(in) :: alpha_ref !< A mean specific volume that is subtracted out - !! to reduce the magnitude of each of the integrals [R-1 ~> m3 kg-1]. + !! to reduce the magnitude of each of the integrals [R-1 ~> m3 kg-1] !! The calculation is mathematically identical with different values of !! alpha_ref, but this reduces the effects of roundoff. type(EOS_type), pointer :: EOS !< Equation of state structure real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & intent(inout) :: dza !< The change in the geopotential anomaly across - !! the layer [T-2 ~> m2 s-2] or [m2 s-2]. + !! the layer [T-2 ~> m2 s-2] or [m2 s-2] real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & optional, intent(inout) :: intp_dza !< The integral in pressure through the layer of the !! geopotential anomaly relative to the anomaly at the bottom of the - !! layer [R L4 T-4 ~> Pa m2 s-2] or [Pa m2 s-2]. + !! layer [R L4 T-4 ~> Pa m2 s-2] or [Pa m2 s-2] real, dimension(HI%IsdB:HI%IedB,HI%jsd:HI%jed), & optional, intent(inout) :: 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 [L2 T-2 ~> m2 s-2] or [m2 s-2]. + !! the x grid spacing [L2 T-2 ~> m2 s-2] or [m2 s-2] real, dimension(HI%isd:HI%ied,HI%JsdB:HI%JedB), & optional, intent(inout) :: 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 [L2 T-2 ~> m2 s-2] or [m2 s-2]. + !! the y grid spacing [L2 T-2 ~> m2 s-2] or [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 [R L2 T-2 ~> Pa] or [Pa] @@ -1308,9 +1308,9 @@ subroutine int_density_dz(T, S, z_t, z_b, rho_ref, rho_0, G_e, HII, HIO, EOS, dp real, dimension(HII%isd:HII%ied,HII%jsd:HII%jed), & intent(in) :: S !< Salinity [ppt] real, dimension(HII%isd:HII%ied,HII%jsd:HII%jed), & - intent(in) :: z_t !< Height at the top of the layer in depth units [Z ~> m]. + intent(in) :: z_t !< Height at the top of the layer in depth units [Z ~> m] real, dimension(HII%isd:HII%ied,HII%jsd:HII%jed), & - intent(in) :: z_b !< Height at the bottom of the layer [Z ~> m]. + intent(in) :: z_b !< Height at the bottom of the layer [Z ~> m] real, intent(in) :: rho_ref !< A mean density [R ~> kg m-3] or [kg m-3], that is !! subtracted out to reduce the magnitude of each of the !! integrals. @@ -1318,34 +1318,34 @@ subroutine int_density_dz(T, S, z_t, z_b, rho_ref, rho_0, G_e, HII, HIO, EOS, dp !! 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 - !! [L2 Z-1 T-2 ~> m s-2] or [m2 Z-1 s-2 ~> m s-2]. + !! [L2 Z-1 T-2 ~> m s-2] or [m2 Z-1 s-2 ~> m s-2] type(EOS_type), pointer :: EOS !< Equation of state structure real, dimension(HIO%isd:HIO%ied,HIO%jsd:HIO%jed), & intent(inout) :: dpa !< The change in the pressure anomaly - !! across the layer [R L2 T-2 ~> Pa] or [Pa]. + !! across the layer [R L2 T-2 ~> Pa] or [Pa] real, dimension(HIO%isd:HIO%ied,HIO%jsd:HIO%jed), & optional, intent(inout) :: intz_dpa !< The integral through the thickness of the !! layer of the pressure anomaly relative to the - !! anomaly at the top of the layer [R L2 Z T-2 ~> Pa m]. + !! anomaly at the top of the layer [R L2 Z T-2 ~> Pa m] real, dimension(HIO%IsdB:HIO%IedB,HIO%jsd:HIO%jed), & optional, intent(inout) :: 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 [R L2 T-2 ~> Pa]. + !! layer divided by the x grid spacing [R L2 T-2 ~> Pa] real, dimension(HIO%isd:HIO%ied,HIO%JsdB:HIO%JedB), & optional, intent(inout) :: 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 [R L2 T-2 ~> Pa]. + !! layer divided by the y grid spacing [R L2 T-2 ~> Pa] real, dimension(HII%isd:HII%ied,HII%jsd:HII%jed), & - optional, intent(in) :: bathyT !< The depth of the bathymetry [Z ~> m]. - real, optional, intent(in) :: dz_neglect !< A miniscule thickness change [Z ~> m]. + optional, intent(in) :: bathyT !< The depth of the bathymetry [Z ~> m] + real, optional, intent(in) :: dz_neglect !< A miniscule thickness change [Z ~> m] logical, optional, intent(in) :: useMassWghtInterp !< If true, uses mass weighting to !! interpolate T/S for top and bottom integrals. type(unit_scale_type), optional, intent(in) :: US !< A dimensional unit scaling type ! Local variables real :: rho_scale ! A multiplicative factor by which to scale density from kg m-3 to the - ! desired units [R m3 kg-1 ~> 1]. - real :: pres_scale ! A multiplicative factor to convert pressure into Pa [Pa T2 R-1 L-2 ~> 1]. + ! desired units [R m3 kg-1 ~> 1] + real :: pres_scale ! A multiplicative factor to convert pressure into Pa [Pa T2 R-1 L-2 ~> 1] if (.not.associated(EOS)) call MOM_error(FATAL, & "int_density_dz called with an unassociated EOS_type EOS.") @@ -1509,11 +1509,11 @@ subroutine EOS_manual_init(EOS, form_of_EOS, form_of_TFreeze, EOS_quadrature, Co !! in [kg m-3 degC-1] real , optional, intent(in) :: dRho_dS !< Partial derivative of density with salinity !! in [kg m-3 ppt-1] - real , optional, intent(in) :: TFr_S0_P0 !< The freezing potential temperature at S=0, P=0 [degC]. + real , optional, intent(in) :: TFr_S0_P0 !< The freezing potential temperature at S=0, P=0 [degC] real , optional, intent(in) :: dTFr_dS !< The derivative of freezing point with salinity - !! in [degC ppt-1]. + !! in [degC ppt-1] real , optional, intent(in) :: dTFr_dp !< The derivative of freezing point with pressure - !! in [degC Pa-1]. + !! in [degC Pa-1] if (present(form_of_EOS )) EOS%form_of_EOS = form_of_EOS if (present(form_of_TFreeze)) EOS%form_of_TFreeze = form_of_TFreeze @@ -1577,13 +1577,13 @@ subroutine int_density_dz_generic(T, S, z_t, z_b, rho_ref, rho_0, G_e, HII, HIO, 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 [degC]. + intent(in) :: T !< Potential temperature of the layer [degC] real, dimension(HII%isd:HII%ied,HII%jsd:HII%jed), & - intent(in) :: S !< Salinity of the layer [ppt]. + intent(in) :: S !< Salinity of the layer [ppt] real, dimension(HII%isd:HII%ied,HII%jsd:HII%jed), & - intent(in) :: z_t !< Height at the top of the layer in depth units [Z ~> m]. + intent(in) :: z_t !< Height at the top of the layer in depth units [Z ~> m] real, dimension(HII%isd:HII%ied,HII%jsd:HII%jed), & - intent(in) :: z_b !< Height at the bottom of the layer [Z ~> m]. + intent(in) :: z_b !< Height at the bottom of the layer [Z ~> m] real, intent(in) :: rho_ref !< A mean density [R ~> kg m-3] or [kg m-3], that is !! subtracted out to reduce the magnitude !! of each of the integrals. @@ -1591,26 +1591,26 @@ subroutine int_density_dz_generic(T, S, z_t, z_b, rho_ref, rho_0, G_e, HII, HIO, !! 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 - !! [L2 Z-1 T-2 ~> m s-2] or [m2 Z-1 s-2 ~> m s-2]. + !! [L2 Z-1 T-2 ~> m s-2] or [m2 Z-1 s-2 ~> m s-2] type(EOS_type), pointer :: EOS !< Equation of state structure real, dimension(HIO%isd:HIO%ied,HIO%jsd:HIO%jed), & intent(inout) :: dpa !< The change in the pressure anomaly - !! across the layer [R L2 T-2 ~> Pa] or [Pa]. + !! across the layer [R L2 T-2 ~> Pa] or [Pa] real, dimension(HIO%isd:HIO%ied,HIO%jsd:HIO%jed), & optional, intent(inout) :: intz_dpa !< The integral through the thickness of the !! layer of the pressure anomaly relative to the - !! anomaly at the top of the layer [R L2 Z T-2 ~> Pa m]. + !! anomaly at the top of the layer [R L2 Z T-2 ~> Pa m] real, dimension(HIO%IsdB:HIO%IedB,HIO%jsd:HIO%jed), & optional, intent(inout) :: 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 [R L2 T-2 ~> Pa]. + !! layer divided by the x grid spacing [R L2 T-2 ~> Pa] real, dimension(HIO%isd:HIO%ied,HIO%JsdB:HIO%JedB), & optional, intent(inout) :: 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 [R L2 T-2 ~> Pa]. + !! layer divided by the y grid spacing [R L2 T-2 ~> Pa] real, dimension(HII%isd:HII%ied,HII%jsd:HII%jed), & - optional, intent(in) :: bathyT !< The depth of the bathymetry [Z ~> m]. - real, optional, intent(in) :: dz_neglect !< A miniscule thickness change [Z ~> m]. + optional, intent(in) :: bathyT !< The depth of the bathymetry [Z ~> m] + real, optional, intent(in) :: dz_neglect !< A miniscule thickness change [Z ~> m] logical, optional, intent(in) :: useMassWghtInterp !< If true, uses mass weighting to !! interpolate T/S for top and bottom integrals. type(unit_scale_type), optional, intent(in) :: US !< A dimensional unit scaling type @@ -1619,23 +1619,23 @@ subroutine int_density_dz_generic(T, S, z_t, z_b, rho_ref, rho_0, G_e, HII, HIO, real :: T5(5), S5(5) ! Temperatures and salinities at five quadrature points [degC] and [ppt] real :: p5(5) ! Pressures at five quadrature points, never rescaled from Pa [Pa] real :: r5(5) ! Densities at five quadrature points [R ~> kg m-3] or [kg m-3] - real :: rho_anom ! The depth averaged density anomaly [R ~> kg m-3] or [kg m-3]. - real :: w_left, w_right ! Left and right weights [nondim]. + real :: rho_anom ! The depth averaged density anomaly [R ~> kg m-3] or [kg m-3] + real :: w_left, w_right ! Left and right weights [nondim] real, parameter :: C1_90 = 1.0/90.0 ! Rational constants. real :: GxRho ! The gravitational acceleration times density and unit conversion factors [Pa Z-1 ~> kg m-2 s-2] real :: I_Rho ! The inverse of the Boussinesq density [R-1 ~> m3 kg-1] or [m3 kg-1] real :: rho_scale ! A scaling factor for densities from kg m-3 to R [R m3 kg-1 ~> 1] real :: rho_ref_mks ! The reference density in MKS units, never rescaled from kg m-3 [kg m-3] - real :: dz ! The layer thickness [Z ~> m]. - real :: hWght ! A pressure-thickness below topography [Z ~> m]. - real :: hL, hR ! Pressure-thicknesses of the columns to the left and right [Z ~> m]. - real :: iDenom ! The inverse of the denominator in the weights [Z-2 ~> 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 weights of the left and right columns [nondim]. - real :: wtT_L, wtT_R ! The weights for tracers from the left and right columns [nondim]. + real :: dz ! The layer thickness [Z ~> m] + real :: hWght ! A pressure-thickness below topography [Z ~> m] + real :: hL, hR ! Pressure-thicknesses of the columns to the left and right [Z ~> m] + real :: iDenom ! The inverse of the denominator in the weights [Z-2 ~> 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 weights 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 gravitational acceleration times the integrals of density - ! with height at the 5 sub-column locations [R L2 T-2 ~> Pa] or [Pa]. + ! with height at the 5 sub-column locations [R L2 T-2 ~> Pa] or [Pa] logical :: do_massWeight ! Indicates whether to do mass weighting. integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, i, j, m, n, ioff, joff @@ -1794,32 +1794,32 @@ subroutine int_density_dz_generic_plm (T_t, T_b, S_t, S_b, z_t, z_b, rho_ref, & real, dimension(HII%isd:HII%ied,HII%jsd:HII%jed), & intent(in) :: S_b !< Salinity at the cell bottom [ppt] real, dimension(HII%isd:HII%ied,HII%jsd:HII%jed), & - intent(in) :: z_t !< The geometric height at the top of the layer [Z ~> m]. + intent(in) :: z_t !< The geometric height at the top of the layer [Z ~> m] real, dimension(HII%isd:HII%ied,HII%jsd:HII%jed), & - intent(in) :: z_b !< The geometric height at the bottom of the layer [Z ~> m]. + intent(in) :: z_b !< The geometric height at the bottom of the layer [Z ~> m] real, intent(in) :: rho_ref !< A mean density [R ~> kg m-3] or [kg m-3], that is subtracted !! out to reduce the magnitude of each of the integrals. real, intent(in) :: rho_0 !< A density [R ~> kg m-3] or [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 [L2 Z-1 T-2 ~> m s-2]. - real, intent(in) :: dz_subroundoff !< A miniscule thickness change [Z ~> m]. + real, intent(in) :: G_e !< The Earth's gravitational acceleration [L2 Z-1 T-2 ~> m s-2] + real, intent(in) :: dz_subroundoff !< A miniscule thickness change [Z ~> m] real, dimension(HII%isd:HII%ied,HII%jsd:HII%jed), & - intent(in) :: bathyT !< The depth of the bathymetry [Z ~> m]. + intent(in) :: bathyT !< The depth of the bathymetry [Z ~> m] type(EOS_type), pointer :: EOS !< Equation of state structure real, dimension(HIO%isd:HIO%ied,HIO%jsd:HIO%jed), & - intent(inout) :: dpa !< The change in the pressure anomaly across the layer [R L2 T-2 ~> Pa]. + intent(inout) :: dpa !< The change in the pressure anomaly across the layer [R L2 T-2 ~> Pa] real, dimension(HIO%isd:HIO%ied,HIO%jsd:HIO%jed), & optional, intent(inout) :: intz_dpa !< The integral through the thickness of the layer of !! the pressure anomaly relative to the anomaly at the - !! top of the layer [R L2 Z T-2 ~> Pa Z]. + !! top of the layer [R L2 Z T-2 ~> Pa Z] real, dimension(HIO%IsdB:HIO%IedB,HIO%jsd:HIO%jed), & optional, intent(inout) :: 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 [R L2 T-2 ~> Pa]. + !! divided by the x grid spacing [R L2 T-2 ~> Pa] real, dimension(HIO%isd:HIO%ied,HIO%JsdB:HIO%JedB), & optional, intent(inout) :: 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 [R L2 T-2 ~> Pa]. + !! divided by the y grid spacing [R L2 T-2 ~> Pa] logical, optional, intent(in) :: useMassWghtInterp !< If true, uses mass weighting to !! interpolate T/S for top and bottom integrals. type(unit_scale_type), optional, intent(in) :: US !< A dimensional unit scaling type @@ -1836,37 +1836,37 @@ subroutine int_density_dz_generic_plm (T_t, T_b, S_t, S_b, z_t, z_b, rho_ref, & ! a linear interpolation is used to compute intermediate values. ! Local variables - real :: T5((5*HIO%iscB+1):(5*(HIO%iecB+2))) ! Temperatures along a line of subgrid locations [degC]. - real :: S5((5*HIO%iscB+1):(5*(HIO%iecB+2))) ! Salinities along a line of subgrid locations [ppt]. + real :: T5((5*HIO%iscB+1):(5*(HIO%iecB+2))) ! Temperatures along a line of subgrid locations [degC] + real :: S5((5*HIO%iscB+1):(5*(HIO%iecB+2))) ! Salinities along a line of subgrid locations [ppt] real :: p5((5*HIO%iscB+1):(5*(HIO%iecB+2))) ! Pressures along a line of subgrid locations, never - ! rescaled from Pa [Pa]. + ! rescaled from Pa [Pa] real :: r5((5*HIO%iscB+1):(5*(HIO%iecB+2))) ! Densities anomalies along a line of subgrid - ! locations [R ~> kg m-3] or [kg m-3]. - real :: T15((15*HIO%iscB+1):(15*(HIO%iecB+1))) ! Temperatures at an array of subgrid locations [degC]. - real :: S15((15*HIO%iscB+1):(15*(HIO%iecB+1))) ! Salinities at an array of subgrid locations [ppt]. - real :: p15((15*HIO%iscB+1):(15*(HIO%iecB+1))) ! Pressures at an array of subgrid locations [Pa]. + ! locations [R ~> kg m-3] or [kg m-3] + real :: T15((15*HIO%iscB+1):(15*(HIO%iecB+1))) ! Temperatures at an array of subgrid locations [degC] + real :: S15((15*HIO%iscB+1):(15*(HIO%iecB+1))) ! Salinities at an array of subgrid locations [ppt] + real :: p15((15*HIO%iscB+1):(15*(HIO%iecB+1))) ! Pressures at an array of subgrid locations [Pa] real :: r15((15*HIO%iscB+1):(15*(HIO%iecB+1))) ! Densities at an array of subgrid locations - ! [R ~> kg m-3] or [kg m-3]. - real :: wt_t(5), wt_b(5) ! Top and bottom weights [nondim]. - real :: rho_anom ! A density anomaly [R ~> kg m-3] or [kg m-3]. - real :: w_left, w_right ! Left and right weights [nondim]. + ! [R ~> kg m-3] or [kg m-3] + real :: wt_t(5), wt_b(5) ! Top and bottom weights [nondim] + real :: rho_anom ! A density anomaly [R ~> kg m-3] or [kg m-3] + real :: w_left, w_right ! Left and right weights [nondim] real :: intz(5) ! The gravitational acceleration times the integrals of density - ! with height at the 5 sub-column locations [R L2 T-2 ~> Pa] or [Pa]. - real, parameter :: C1_90 = 1.0/90.0 ! A rational constant [nondim]. + ! with height at the 5 sub-column locations [R L2 T-2 ~> Pa] or [Pa] + real, parameter :: C1_90 = 1.0/90.0 ! A rational constant [nondim] real :: GxRho ! The gravitational acceleration times density and unit conversion factors [Pa Z-1 ~> kg m-2 s-2] real :: I_Rho ! The inverse of the Boussinesq density [R-1 ~> m3 kg-1] or [m3 kg-1] real :: rho_scale ! A scaling factor for densities from kg m-3 to R [R m3 kg-1 ~> 1] real :: rho_ref_mks ! The reference density in MKS units, never rescaled from kg m-3 [kg m-3] - real :: dz(HIO%iscB:HIO%iecB+1) ! Layer thicknesses at tracer points [Z ~> m]. - real :: dz_x(5,HIO%iscB:HIO%iecB) ! Layer thicknesses along an x-line of subrid locations [Z ~> m]. - real :: dz_y(5,HIO%isc:HIO%iec) ! Layer thicknesses along a y-line of subrid locations [Z ~> m]. - real :: weight_t, weight_b ! Nondimensional weights of the top and bottom. - real :: massWeightToggle ! A nondimensional toggle factor (0 or 1). - real :: Ttl, Tbl, Ttr, Tbr ! Temperatures at the velocity cell corners [degC]. - real :: Stl, Sbl, Str, Sbr ! Salinities at the velocity cell corners [ppt]. - real :: hWght ! A topographically limited thicknes weight [Z ~> m]. - real :: hL, hR ! Thicknesses to the left and right [Z ~> m]. - real :: iDenom ! The denominator of the thickness weight expressions [Z-2 ~> m-2]. + real :: dz(HIO%iscB:HIO%iecB+1) ! Layer thicknesses at tracer points [Z ~> m] + real :: dz_x(5,HIO%iscB:HIO%iecB) ! Layer thicknesses along an x-line of subrid locations [Z ~> m] + real :: dz_y(5,HIO%isc:HIO%iec) ! Layer thicknesses along a y-line of subrid locations [Z ~> m] + real :: weight_t, weight_b ! Nondimensional weights of the top and bottom [nondim] + real :: massWeightToggle ! A nondimensional toggle factor (0 or 1) [nondim] + real :: Ttl, Tbl, Ttr, Tbr ! Temperatures at the velocity cell corners [degC] + real :: Stl, Sbl, Str, Sbr ! Salinities at the velocity cell corners [ppt] + real :: hWght ! A topographically limited thicknes weight [Z ~> m] + real :: hL, hR ! Thicknesses to the left and right [Z ~> m] + real :: iDenom ! The denominator of the thickness weight expressions [Z-2 ~> m-2] integer :: Isq, Ieq, Jsq, Jeq, i, j, m, n integer :: iin, jin, ioff, joff integer :: pos @@ -2108,16 +2108,16 @@ subroutine find_depth_of_pressure_in_cell(T_t, T_b, S_t, S_b, z_t, z_b, P_t, P_t real, intent(in) :: T_b !< Potential temperatue at the cell bottom [degC] real, intent(in) :: S_t !< Salinity at the cell top [ppt] real, intent(in) :: S_b !< Salinity at the cell bottom [ppt] - real, intent(in) :: z_t !< Absolute height of top of cell [Z ~> m]. (Boussinesq ????) - real, intent(in) :: z_b !< Absolute height of bottom of cell [Z ~> m]. + real, intent(in) :: z_t !< Absolute height of top of cell [Z ~> m] (Boussinesq ????) + real, intent(in) :: z_b !< Absolute height of bottom of cell [Z ~> m] real, intent(in) :: P_t !< Anomalous pressure of top of cell, relative to g*rho_ref*z_t [Pa] real, intent(in) :: P_tgt !< Target pressure at height z_out, relative to g*rho_ref*z_out [Pa] real, intent(in) :: rho_ref !< Reference density with which calculation are anomalous to real, intent(in) :: G_e !< Gravitational acceleration [m2 Z-1 s-2 ~> m s-2] type(EOS_type), pointer :: EOS !< Equation of state structure real, intent(out) :: P_b !< Pressure at the bottom of the cell [Pa] - real, intent(out) :: z_out !< Absolute depth at which anomalous pressure = p_tgt [Z ~> m]. - real, optional, intent(in) :: z_tol !< The tolerance in finding z_out [Z ~> m]. + real, intent(out) :: z_out !< Absolute depth at which anomalous pressure = p_tgt [Z ~> m] + real, optional, intent(in) :: z_tol !< The tolerance in finding z_out [Z ~> m] ! Local variables real :: top_weight, bottom_weight, rho_anom, w_left, w_right, GxRho, dz, dp, F_guess, F_l, F_r real :: Pa, Pa_left, Pa_right, Pa_tol ! Pressure anomalies, P = integral of g*(rho-rho_ref) dz @@ -2185,7 +2185,7 @@ real function frac_dp_at_pos(T_t, T_b, S_t, S_b, z_t, z_b, rho_ref, G_e, pos, EO real, intent(in) :: rho_ref !< A mean density [kg m-3], that is subtracted out to !! reduce the magnitude of each of the integrals. real, intent(in) :: G_e !< The Earth's gravitational acceleration [m s-2] - real, intent(in) :: pos !< The fractional vertical position, 0 to 1 [nondim]. + real, intent(in) :: pos !< The fractional vertical position, 0 to 1 [nondim] type(EOS_type), pointer :: EOS !< Equation of state structure ! Local variables real, parameter :: C1_90 = 1.0/90.0 ! Rational constants. @@ -2235,9 +2235,9 @@ subroutine int_density_dz_generic_ppm(T, T_t, T_b, S, S_t, S_b, & real, dimension(HII%isd:HII%ied,HII%jsd:HII%jed), & intent(in) :: S_b !< Salinity at the cell bottom [ppt] real, dimension(HII%isd:HII%ied,HII%jsd:HII%jed), & - intent(in) :: z_t !< Height at the top of the layer [Z ~> m]. + intent(in) :: z_t !< Height at the top of the layer [Z ~> m] real, dimension(HII%isd:HII%ied,HII%jsd:HII%jed), & - intent(in) :: z_b !< Height at the bottom of the layer [Z ~> m]. + intent(in) :: z_b !< Height at the bottom of the layer [Z ~> m] real, intent(in) :: rho_ref !< A mean density [R ~> kg m-3] or [kg m-3], that is !! subtracted out to reduce the magnitude of each of the integrals. real, intent(in) :: rho_0 !< A density [R ~> kg m-3] or [kg m-3], that is used to calculate @@ -2245,19 +2245,19 @@ subroutine int_density_dz_generic_ppm(T, T_t, T_b, S, S_t, S_b, & real, intent(in) :: G_e !< The Earth's gravitational acceleration [m s-2] type(EOS_type), pointer :: EOS !< Equation of state structure real, dimension(HIO%isd:HIO%ied,HIO%jsd:HIO%jed), & - intent(inout) :: dpa !< The change in the pressure anomaly across the layer [Pa]. + intent(inout) :: dpa !< The change in the pressure anomaly across the layer [R L2 T-2 ~> Pa] real, dimension(HIO%isd:HIO%ied,HIO%jsd:HIO%jed), & optional, intent(inout) :: intz_dpa !< The integral through the thickness of the layer of !! the pressure anomaly relative to the anomaly at the - !! top of the layer [Pa Z ~> Pa m]. + !! top of the layer [R L2 Z T-2 ~> Pa m] real, dimension(HIO%IsdB:HIO%IedB,HIO%jsd:HIO%jed), & optional, intent(inout) :: 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 [Pa]. + !! divided by the x grid spacing [R L2 T-2 ~> Pa] real, dimension(HIO%isd:HIO%ied,HIO%JsdB:HIO%JedB), & optional, intent(inout) :: 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 [Pa]. + !! divided by the y grid spacing [R L2 T-2 ~> Pa] type(unit_scale_type), optional, intent(in) :: US !< A dimensional unit scaling type ! This subroutine calculates (by numerical quadrature) integrals of @@ -2278,9 +2278,9 @@ subroutine int_density_dz_generic_ppm(T, T_t, T_b, S, S_t, S_b, & real :: p5(5) ! Pressures at five quadrature points, never rescaled from Pa [Pa] real :: r5(5) ! Density anomalies from rho_ref at quadrature points [R ~> kg m-3] or [kg m-3] real :: rho_anom ! The integrated density anomaly [R ~> kg m-3] or [kg m-3] - real :: w_left, w_right ! Left and right weights [nondim]. + real :: w_left, w_right ! Left and right weights [nondim] real :: intz(5) ! The gravitational acceleration times the integrals of density - ! with height at the 5 sub-column locations [R L2 T-2 ~> Pa] or [Pa]. + ! with height at the 5 sub-column locations [R L2 T-2 ~> Pa] or [Pa] real, parameter :: C1_90 = 1.0/90.0 ! Rational constants. real :: GxRho ! The gravitational acceleration times density and unit conversion factors [Pa Z-1 ~> kg m-2 s-2] real :: I_Rho ! The inverse of the Boussinesq density [R-1 ~> m3 kg-1] or [m3 kg-1] @@ -2679,34 +2679,34 @@ subroutine int_spec_vol_dp_generic(T, S, p_t, p_b, alpha_ref, HI, EOS, dza, & bathyP, dP_neglect, useMassWghtInterp, US) 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 !< Potential temperature of the layer [degC]. + intent(in) :: T !< Potential temperature of the layer [degC] real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & - intent(in) :: S !< Salinity of the layer [ppt]. + intent(in) :: S !< Salinity of the layer [ppt] real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & - intent(in) :: p_t !< Pressure atop the layer [R L2 T-2 ~> Pa] or [Pa]. + intent(in) :: p_t !< Pressure atop the layer [R L2 T-2 ~> Pa] or [Pa] real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & - intent(in) :: p_b !< Pressure below the layer [R L2 T-2 ~> Pa] or [Pa]. + intent(in) :: p_b !< Pressure below the layer [R L2 T-2 ~> Pa] or [Pa] real, intent(in) :: alpha_ref !< A mean specific volume that is subtracted out - !! to reduce the magnitude of each of the integrals [R-1 ~> m3 kg-1]. + !! to reduce the magnitude of each of the integrals [R-1 ~> 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(inout) :: dza !< The change in the geopotential anomaly - !! across the layer [L2 T-2 ~> m2 s-2] or [m2 s-2]. + !! across the layer [L2 T-2 ~> m2 s-2] or [m2 s-2] real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & optional, intent(inout) :: intp_dza !< The integral in pressure through the layer of !! the geopotential anomaly relative to the anomaly at the bottom of the - !! layer [R L4 T-4 ~> Pa m2 s-2] or [Pa m2 s-2]. + !! layer [R L4 T-4 ~> Pa m2 s-2] or [Pa m2 s-2] real, dimension(HI%IsdB:HI%IedB,HI%jsd:HI%jed), & optional, intent(inout) :: 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 [L2 T-2 ~> m2 s-2] or [m2 s-2]. + !! by the x grid spacing [L2 T-2 ~> m2 s-2] or [m2 s-2] real, dimension(HI%isd:HI%ied,HI%JsdB:HI%JedB), & optional, intent(inout) :: 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 [L2 T-2 ~> m2 s-2] or [m2 s-2]. + !! by the y grid spacing [L2 T-2 ~> m2 s-2] or [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 [R L2 T-2 ~> Pa] or [Pa] @@ -2728,18 +2728,18 @@ subroutine int_spec_vol_dp_generic(T, S, p_t, p_b, alpha_ref, HI, EOS, dza, & real :: S5(5) ! Salinities at five quadrature points [ppt] real :: p5(5) ! Pressures at five quadrature points, scaled back to Pa if necessary [Pa] real :: a5(5) ! Specific volumes at five quadrature points [R-1 ~> m3 kg-1] or [m3 kg-1] - real :: alpha_anom ! The depth averaged specific density anomaly [R-1 ~> m3 kg-1]. - real :: dp ! The pressure change through a layer [R L2 T-2 ~> Pa]. - real :: hWght ! A pressure-thickness below topography [R L2 T-2 ~> Pa]. - real :: hL, hR ! Pressure-thicknesses of the columns to the left and right [R L2 T-2 ~> Pa]. + real :: alpha_anom ! The depth averaged specific density anomaly [R-1 ~> m3 kg-1] + real :: dp ! The pressure change through a layer [R L2 T-2 ~> Pa] + real :: hWght ! A pressure-thickness below topography [R L2 T-2 ~> Pa] + real :: hL, hR ! Pressure-thicknesses of the columns to the left and right [R L2 T-2 ~> Pa] real :: alpha_ref_mks ! The reference specific volume in MKS units, never rescaled from m3 kg-1 [m3 kg-1] - real :: iDenom ! The inverse of the denominator in the weights [T4 R-2 L-4 ~> 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 weights of the left and right columns [nondim]. - real :: wtT_L, wtT_R ! The weights for tracers from the left and right columns [nondim]. + real :: iDenom ! The inverse of the denominator in the weights [T4 R-2 L-4 ~> 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 weights 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 [L2 T-2 ~> m2 s-2]. + ! 5 sub-column locations [L2 T-2 ~> m2 s-2] real :: RL2_T2_to_Pa ! A unit conversion factor from the rescaled units of pressure to Pa [Pa T2 R-1 L-2 ~> 1] real :: SV_scale ! A multiplicative factor by which to scale specific ! volume from m3 kg-1 to the desired units [kg m-3 R-1 ~> 1] @@ -2894,19 +2894,19 @@ subroutine int_spec_vol_dp_generic_plm(T_t, T_b, S_t, S_b, p_t, p_b, alpha_ref, intp_dza, intx_dza, inty_dza, useMassWghtInterp, US) 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 [degC]. + intent(in) :: T_t !< Potential temperature at the top of the layer [degC] real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & - intent(in) :: T_b !< Potential temperature at the bottom of the layer [degC]. + intent(in) :: T_b !< Potential temperature at the bottom of the layer [degC] real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & - intent(in) :: S_t !< Salinity at the top the layer [ppt]. + intent(in) :: S_t !< Salinity at the top the layer [ppt] real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & - intent(in) :: S_b !< Salinity at the bottom the layer [ppt]. + intent(in) :: S_b !< Salinity at the bottom the layer [ppt] real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & - intent(in) :: p_t !< Pressure atop the layer [R L2 T-2 ~> Pa] or [Pa]. + intent(in) :: p_t !< Pressure atop the layer [R L2 T-2 ~> Pa] or [Pa] real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & - intent(in) :: p_b !< Pressure below the layer [R L2 T-2 ~> Pa] or [Pa]. + intent(in) :: p_b !< Pressure below the layer [R L2 T-2 ~> Pa] or [Pa] real, intent(in) :: alpha_ref !< A mean specific volume that is subtracted out - !! to reduce the magnitude of each of the integrals [R-1 ~> m3 kg-1]. + !! to reduce the magnitude of each of the integrals [R-1 ~> 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. @@ -2917,19 +2917,19 @@ subroutine int_spec_vol_dp_generic_plm(T_t, T_b, S_t, S_b, p_t, p_b, alpha_ref, type(EOS_type), pointer :: EOS !< Equation of state structure real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & intent(inout) :: dza !< The change in the geopotential anomaly - !! across the layer [L2 T-2 ~> m2 s-2]. + !! across the layer [L2 T-2 ~> m2 s-2] real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & optional, intent(inout) :: intp_dza !< The integral in pressure through the layer of !! the geopotential anomaly relative to the anomaly at the bottom of the - !! layer [R L4 T-4 ~> Pa m2 s-2] or [Pa m2 s-2]. + !! layer [R L4 T-4 ~> Pa m2 s-2] or [Pa m2 s-2] real, dimension(HI%IsdB:HI%IedB,HI%jsd:HI%jed), & optional, intent(inout) :: 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 [L2 T-2 ~> m2 s-2] or [m2 s-2]. + !! by the x grid spacing [L2 T-2 ~> m2 s-2] or [m2 s-2] real, dimension(HI%isd:HI%ied,HI%JsdB:HI%JedB), & optional, intent(inout) :: 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 [L2 T-2 ~> m2 s-2] or [m2 s-2]. + !! by the y grid spacing [L2 T-2 ~> m2 s-2] or [m2 s-2] logical, optional, intent(in) :: useMassWghtInterp !< If true, uses mass weighting !! to interpolate T/S for top and bottom integrals. type(unit_scale_type), optional, intent(in) :: US !< A dimensional unit scaling type @@ -2952,19 +2952,19 @@ subroutine int_spec_vol_dp_generic_plm(T_t, T_b, S_t, S_b, p_t, p_b, alpha_ref, real :: wt_t(5), wt_b(5) ! Weights of top and bottom values at quadrature points [nondim] real :: T_top, T_bot, S_top, S_bot, P_top, P_bot - real :: alpha_anom ! The depth averaged specific density anomaly [m3 kg-1]. - real :: dp ! The pressure change through a layer [R L2 T-2 ~> Pa]. - real :: dp_90(2:4) ! The pressure change through a layer divided by 90 [R L2 T-2 ~> Pa]. - real :: hWght ! A pressure-thickness below topography [R L2 T-2 ~> Pa]. - real :: hL, hR ! Pressure-thicknesses of the columns to the left and right [R L2 T-2 ~> Pa]. + real :: alpha_anom ! The depth averaged specific density anomaly [m3 kg-1] + real :: dp ! The pressure change through a layer [R L2 T-2 ~> Pa] + real :: dp_90(2:4) ! The pressure change through a layer divided by 90 [R L2 T-2 ~> Pa] + real :: hWght ! A pressure-thickness below topography [R L2 T-2 ~> Pa] + real :: hL, hR ! Pressure-thicknesses of the columns to the left and right [R L2 T-2 ~> Pa] real :: alpha_ref_mks ! The reference specific volume in MKS units, never rescaled from m3 kg-1 [m3 kg-1] - real :: iDenom ! The inverse of the denominator in the weights [T4 R-2 L-4 ~> 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 weights of the left and right columns [nondim]. - real :: wtT_L, wtT_R ! The weights for tracers from the left and right columns [nondim]. + real :: iDenom ! The inverse of the denominator in the weights [T4 R-2 L-4 ~> 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 weights 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 [L2 T-2 ~> m2 s-2]. + ! 5 sub-column locations [L2 T-2 ~> m2 s-2] real :: RL2_T2_to_Pa ! A unit conversion factor from the rescaled units of pressure to Pa [Pa T2 R-1 L-2 ~> 1] real :: SV_scale ! A multiplicative factor by which to scale specific ! volume from m3 kg-1 to the desired units [kg m-3 R-1 ~> 1] @@ -3189,11 +3189,11 @@ subroutine extract_member_EOS(EOS, form_of_EOS, form_of_TFreeze, EOS_quadrature, !! in [kg m-3 degC-1] real , optional, intent(out) :: dRho_dS !< Partial derivative of density with salinity !! in [kg m-3 ppt-1] - real , optional, intent(out) :: TFr_S0_P0 !< The freezing potential temperature at S=0, P=0 [degC]. + real , optional, intent(out) :: TFr_S0_P0 !< The freezing potential temperature at S=0, P=0 [degC] real , optional, intent(out) :: dTFr_dS !< The derivative of freezing point with salinity - !! [degC PSU-1]. + !! [degC PSU-1] real , optional, intent(out) :: dTFr_dp !< The derivative of freezing point with pressure - !! [degC Pa-1]. + !! [degC Pa-1] if (present(form_of_EOS )) form_of_EOS = EOS%form_of_EOS if (present(form_of_TFreeze)) form_of_TFreeze = EOS%form_of_TFreeze diff --git a/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 b/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 index eae9c94f17..cc3a6e3f69 100644 --- a/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 +++ b/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 @@ -461,7 +461,7 @@ subroutine bulkmixedlayer(h_3d, u_3d, v_3d, tv, fluxes, dt, ea, eb, G, GV, US, C enddo ; enddo if (id_clock_EOS>0) call cpu_clock_begin(id_clock_EOS) - ! Calculate an estimate of the mid-mixed layer pressure [Pa] + ! Calculate an estimate of the mid-mixed layer pressure [R L2 T-2 ~> Pa] do i=is,ie ; p_ref(i) = 0.0 ; enddo do k=1,CS%nkml ; do i=is,ie p_ref(i) = p_ref(i) + 0.5*(GV%H_to_RZ*GV%g_Earth)*h(i,k) diff --git a/src/parameterizations/vertical/MOM_vert_friction.F90 b/src/parameterizations/vertical/MOM_vert_friction.F90 index 5a610095ce..3635f71209 100644 --- a/src/parameterizations/vertical/MOM_vert_friction.F90 +++ b/src/parameterizations/vertical/MOM_vert_friction.F90 @@ -175,8 +175,8 @@ subroutine vertvisc(u, v, h, forces, visc, dt, OBC, ADp, CDp, G, GV, US, CS, & optional, pointer :: Waves !< Container for wave/Stokes information ! Fields from forces used in this subroutine: - ! taux: Zonal wind stress [Pa]. - ! tauy: Meridional wind stress [Pa]. + ! taux: Zonal wind stress [R L Z T-2 ~> Pa]. + ! tauy: Meridional wind stress [R L Z T-2 ~> Pa]. ! Local variables From 8df34f4e2fd33988aa120c4c7bce41ef3ab0eed4 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Mon, 13 Apr 2020 06:56:38 -0400 Subject: [PATCH 171/316] Rescaled internal MOM_diapyc_energy_req variables Rescaled internal pressure, specific volume and energy variables in MOM_diapyc_energy_req.F90. This file is mostly used for testing, and all answers are bitwise identical. --- .../vertical/MOM_diapyc_energy_req.F90 | 125 +++++++++--------- 1 file changed, 66 insertions(+), 59 deletions(-) diff --git a/src/parameterizations/vertical/MOM_diapyc_energy_req.F90 b/src/parameterizations/vertical/MOM_diapyc_energy_req.F90 index fd8d19aa61..cde4b9e484 100644 --- a/src/parameterizations/vertical/MOM_diapyc_energy_req.F90 +++ b/src/parameterizations/vertical/MOM_diapyc_energy_req.F90 @@ -130,7 +130,7 @@ subroutine diapyc_energy_req_calc(h_in, T_in, S_in, Kd, energy_Kd, dt, tv, & !! [Z2 T-1 ~> m2 s-1]. real, intent(in) :: dt !< The amount of time covered by this call [T ~> s]. real, intent(out) :: energy_Kd !< The column-integrated rate of energy - !! consumption by diapycnal diffusion [W m-2]. + !! consumption by diapycnal diffusion [R Z L2 T-3 ~> W m-2]. type(thermo_var_ptrs), intent(inout) :: tv !< A structure containing pointers to any !! available thermodynamic fields. !! Absent fields have NULL ptrs. @@ -147,9 +147,9 @@ subroutine diapyc_energy_req_calc(h_in, T_in, S_in, Kd, energy_Kd, dt, tv, & ! for other bits of code. real, dimension(GV%ke) :: & - p_lay, & ! Average pressure of a layer [Pa]. - dSV_dT, & ! Partial derivative of specific volume with temperature [m3 kg-1 degC-1]. - dSV_dS, & ! Partial derivative of specific volume with salinity [m3 kg-1 ppt-1]. + p_lay, & ! Average pressure of a layer [R L2 T-2 ~> Pa]. + dSV_dT, & ! Partial derivative of specific volume with temperature [R-1 degC-1 ~> m3 kg-1 degC-1]. + dSV_dS, & ! Partial derivative of specific volume with salinity [R-1 ppt-1 ~> m3 kg-1 ppt-1]. T0, S0, & ! Initial temperatures and salinities [degC] and [ppt]. Te, Se, & ! Running incomplete estimates of the new temperatures and salinities [degC] and [ppt]. Te_a, Se_a, & ! Running incomplete estimates of the new temperatures and salinities [degC] and [ppt]. @@ -166,8 +166,8 @@ subroutine diapyc_energy_req_calc(h_in, T_in, S_in, Kd, energy_Kd, dt, tv, & ! mixing effects with other yet lower layers [degC H ~> degC m or degC kg m-2]. Sh_b, & ! An effective salinity times a thickness in the layer below, including implicit ! mixing effects with other yet lower layers [ppt H ~> ppt m or ppt kg m-2]. - dT_to_dPE, & ! Partial derivative of column potential energy with the temperature - dS_to_dPE, & ! and salinity changes within a layer [J m-2 degC-1] and [J m-2 ppt-1]. + dT_to_dPE, & ! Partial derivative of column potential energy with the temperature and salinity + dS_to_dPE, & ! changes within a layer [R Z L2 T-2 degC-1 ~> J m-2 degC-1] and [R Z L2 T-2 ppt-1 ~> J m-2 ppt-1]. dT_to_dColHt, & ! Partial derivatives of the total column height with the temperature dS_to_dColHt, & ! and salinity changes within a layer [Z degC-1 ~> m degC-1] and [Z ppt-1 ~> m ppt-1]. dT_to_dColHt_a, & ! Partial derivatives of the total column height with the temperature @@ -179,11 +179,11 @@ subroutine diapyc_energy_req_calc(h_in, T_in, S_in, Kd, energy_Kd, dt, tv, & dT_to_dPE_a, & ! Partial derivatives of column potential energy with the temperature dS_to_dPE_a, & ! and salinity changes within a layer, including the implicit effects ! of mixing with layers higher in the water column, in - ! units of [J m-2 degC-1] and [J m-2 ppt-1]. + ! units of [R Z L2 T-2 degC-1 ~> J m-2 degC-1] and [R Z L2 T-2 ppt-1 ~> J m-2 ppt-1]. dT_to_dPE_b, & ! Partial derivatives of column potential energy with the temperature dS_to_dPE_b, & ! and salinity changes within a layer, including the implicit effects ! of mixing with layers lower in the water column, in - ! units of [J m-2 degC-1] and [J m-2 ppt-1]. + ! units of [R Z L2 T-2 degC-1 ~> J m-2 degC-1] and [R Z L2 T-2 ppt-1 ~> J m-2 ppt-1]. hp_a, & ! An effective pivot thickness of the layer including the effects ! of coupling with layers above [H ~> m or kg m-2]. This is the first term ! in the denominator of b1 in a downward-oriented tridiagonal solver. @@ -195,9 +195,9 @@ subroutine diapyc_energy_req_calc(h_in, T_in, S_in, Kd, energy_Kd, dt, tv, & h_tr ! h_tr is h at tracer points with a h_neglect added to ! ensure positive definiteness [H ~> m or kg m-2]. real, dimension(GV%ke+1) :: & - pres, & ! Interface pressures [Pa]. + pres, & ! Interface pressures [R L2 T-2 ~> Pa]. pres_Z, & ! Interface pressures with a rescaling factor to convert interface height - ! movements into changes in column potential energy [J m-2 Z-1 ~> J m-3]. + ! movements into changes in column potential energy [R L2 T-2 m Z-1 ~> J m-3]. z_Int, & ! Interface heights relative to the surface [H ~> m or kg m-2]. N2, & ! An estimate of the buoyancy frequency [T-2 ~> s-2]. Kddt_h, & ! The diapycnal diffusivity times a timestep divided by the @@ -211,9 +211,9 @@ subroutine diapyc_energy_req_calc(h_in, T_in, S_in, Kd, energy_Kd, dt, tv, & real, dimension(GV%ke+1,4) :: & PE_chg_k, & ! The integrated potential energy change within a timestep due ! to the diffusivity at interface K for 4 different orders of - ! accumulating the diffusivities [J m-2]. + ! accumulating the diffusivities [R Z L2 T-2 ~> J m-2]. ColHt_cor_k ! The correction to the potential energy change due to - ! changes in the net column height [J m-2]. + ! changes in the net column height [R Z L2 T-2 ~> J m-2]. real :: & b1 ! b1 is used by the tridiagonal solver [H-1 ~> m-1 or m2 kg-1]. real :: & @@ -227,17 +227,17 @@ subroutine diapyc_energy_req_calc(h_in, T_in, S_in, Kd, energy_Kd, dt, tv, & real :: dSe_term ! A diffusivity-independent term related to the salinity ! change in the layer below the interface [ppt H ~> ppt m or ppt kg m-2]. real :: Kddt_h_guess ! A guess of the final value of Kddt_h [H ~> m or kg m-2]. - real :: dMass ! The mass per unit area within a layer [kg m-2]. - real :: dPres ! The hydrostatic pressure change across a layer [Pa]. + real :: dMass ! The mass per unit area within a layer [R Z ~> kg m-2]. + real :: dPres ! The hydrostatic pressure change across a layer [R L2 T-2 ~> Pa]. real :: dMKE_max ! The maximum amount of mean kinetic energy that could be ! converted to turbulent kinetic energy if the velocity in ! the layer below an interface were homogenized with all of - ! the water above the interface [J m-2 = kg s-2]. - real :: rho_here ! The in-situ density [kg m-3]. + ! the water above the interface [R Z L2 T-2 ~> J m-2 = kg s-2]. + real :: rho_here ! The in-situ density [R ~> kg m-3]. real :: PE_change ! The change in column potential energy from applying Kddt_h at the - ! present interface [J m-2]. + ! present interface [R L2 Z T-2 ~> J m-2]. real :: ColHt_cor ! The correction to PE_chg that is made due to a net - ! change in the column height [J m-2]. + ! change in the column height [R L2 Z T-2 ~> J m-2]. real :: htot ! A running sum of thicknesses [H ~> m or kg m-2]. real :: dTe_t2, dT_km1_t2, dT_k_t2 ! Temporary arrays describing temperature changes [degC]. real :: dSe_t2, dS_km1_t2, dS_k_t2 ! Temporary arrays describing salinity changes [ppt]. @@ -280,8 +280,8 @@ subroutine diapyc_energy_req_calc(h_in, T_in, S_in, Kd, energy_Kd, dt, tv, & T0(k) = T_in(k) ; S0(k) = S_in(k) h_tr(k) = h_in(k) htot = htot + h_tr(k) - pres(K+1) = pres(K) + GV%H_to_Pa * h_tr(k) - pres_Z(K+1) = US%Z_to_m * pres(K+1) + pres(K+1) = pres(K) + (GV%g_Earth * GV%H_to_RZ) * h_tr(k) + pres_Z(K+1) = pres(K+1) p_lay(k) = 0.5*(pres(K) + pres(K+1)) Z_int(K+1) = Z_int(K) - h_tr(k) enddo @@ -298,15 +298,15 @@ subroutine diapyc_energy_req_calc(h_in, T_in, S_in, Kd, energy_Kd, dt, tv, & ! Solve the tridiagonal equations for new temperatures. - call calculate_specific_vol_derivs(T0, S0, p_lay, dSV_dT, dSV_dS, 1, nz, tv%eqn_of_state) + call calculate_specific_vol_derivs(T0, S0, p_lay, dSV_dT, dSV_dS, 1, nz, tv%eqn_of_state, US=US) do k=1,nz - dMass = GV%H_to_kg_m2 * h_tr(k) - dPres = GV%H_to_Pa * h_tr(k) + dMass = GV%H_to_RZ * h_tr(k) + dPres = (GV%g_Earth * GV%H_to_RZ) * h_tr(k) dT_to_dPE(k) = (dMass * (pres(K) + 0.5*dPres)) * dSV_dT(k) dS_to_dPE(k) = (dMass * (pres(K) + 0.5*dPres)) * dSV_dS(k) - dT_to_dColHt(k) = dMass * US%m_to_Z * dSV_dT(k) * CS%ColHt_scaling - dS_to_dColHt(k) = dMass * US%m_to_Z * dSV_dS(k) * CS%ColHt_scaling + dT_to_dColHt(k) = dMass * dSV_dT(k) * CS%ColHt_scaling + dS_to_dColHt(k) = dMass * dSV_dS(k) * CS%ColHt_scaling enddo ! PE_chg_k(1) = 0.0 ; PE_chg_k(nz+1) = 0.0 @@ -404,7 +404,7 @@ subroutine diapyc_energy_req_calc(h_in, T_in, S_in, Kd, energy_Kd, dt, tv, & (PE_chg(5)-Pe_chg(1))/(0.04*Kddt_h(K)) dPEa_dKd_err(k) = (dPEa_dKd_est(k) - dPEa_dKd(k)) dPEa_dKd_err_norm(k) = (dPEa_dKd_est(k) - dPEa_dKd(k)) / & - (abs(dPEa_dKd_est(k)) + abs(dPEa_dKd(k)) + 1e-100) + (abs(dPEa_dKd_est(k)) + abs(dPEa_dKd(k)) + 1e-100*US%RZ_to_kg_m2*US%L_T_to_m_s**2) endif ! At this point, the final value of Kddt_h(K) is known, so the estimated @@ -550,7 +550,7 @@ subroutine diapyc_energy_req_calc(h_in, T_in, S_in, Kd, energy_Kd, dt, tv, & (PE_chg(5)-Pe_chg(1))/(0.04*Kddt_h(K)) dPEb_dKd_err(k) = (dPEb_dKd_est(k) - dPEb_dKd(k)) dPEb_dKd_err_norm(k) = (dPEb_dKd_est(k) - dPEb_dKd(k)) / & - (abs(dPEb_dKd_est(k)) + abs(dPEb_dKd(k)) + 1e-100) + (abs(dPEb_dKd_est(k)) + abs(dPEb_dKd(k)) + 1e-100*US%RZ_to_kg_m2*US%L_T_to_m_s**2) endif ! At this point, the final value of Kddt_h(K) is known, so the estimated @@ -917,7 +917,6 @@ subroutine diapyc_energy_req_calc(h_in, T_in, S_in, Kd, energy_Kd, dt, tv, & energy_Kd = 0.0 ; do K=2,nz ; energy_Kd = energy_Kd + PE_chg_k(K,1) ; enddo energy_Kd = energy_Kd / dt - K=nz if (do_print) then if (CS%id_ERt>0) call post_data(CS%id_ERt, PE_chg_k(:,1), CS%diag) @@ -940,7 +939,7 @@ subroutine diapyc_energy_req_calc(h_in, T_in, S_in, Kd, energy_Kd, dt, tv, & N2(1) = 0.0 ; N2(nz+1) = 0.0 do K=2,nz call calculate_density(0.5*(T0(k-1) + T0(k)), 0.5*(S0(k-1) + S0(k)), & - pres(K), rho_here, tv%eqn_of_state) + pres(K), rho_here, tv%eqn_of_state, US=US) N2(K) = ((US%L_to_Z**2*GV%g_Earth) * rho_here / (0.5*GV%H_to_Z*(h_tr(k-1) + h_tr(k)))) * & ( 0.5*(dSV_dT(k-1) + dSV_dT(k)) * (T0(k-1) - T0(k)) + & 0.5*(dSV_dS(k-1) + dSV_dS(k)) * (S0(k-1) - S0(k)) ) @@ -951,7 +950,7 @@ subroutine diapyc_energy_req_calc(h_in, T_in, S_in, Kd, energy_Kd, dt, tv, & N2(1) = 0.0 ; N2(nz+1) = 0.0 do K=2,nz call calculate_density(0.5*(Tf(k-1) + Tf(k)), 0.5*(Sf(k-1) + Sf(k)), & - pres(K), rho_here, tv%eqn_of_state) + pres(K), rho_here, tv%eqn_of_state, US=US) N2(K) = ((US%L_to_Z**2*GV%g_Earth) * rho_here / (0.5*GV%H_to_Z*(h_tr(k-1) + h_tr(k)))) * & ( 0.5*(dSV_dT(k-1) + dSV_dT(k)) * (Tf(k-1) - Tf(k)) + & 0.5*(dSV_dS(k-1) + dSV_dS(k)) * (Sf(k-1) - Sf(k)) ) @@ -997,22 +996,22 @@ subroutine find_PE_chg(Kddt_h0, dKddt_h, hp_a, hp_b, Th_a, Sh_a, Th_b, Sh_b, & real, intent(in) :: dT_to_dPE_a !< A factor (pres_lay*mass_lay*dSpec_vol/dT) relating !! a layer's temperature change to the change in column !! potential energy, including all implicit diffusive changes - !! in the temperatures of all the layers above [J m-2 degC-1]. + !! in the temperatures of all the layers above [R Z L2 T-2 degC-1 ~> J m-2 degC-1]. real, intent(in) :: dS_to_dPE_a !< A factor (pres_lay*mass_lay*dSpec_vol/dS) relating !! a layer's salinity change to the change in column !! potential energy, including all implicit diffusive changes - !! in the salinities of all the layers above [J m-2 ppt-1]. + !! in the salinities of all the layers above [R Z L2 T-2 ppt-1 ~> J m-2 ppt-1]. real, intent(in) :: dT_to_dPE_b !< A factor (pres_lay*mass_lay*dSpec_vol/dT) relating !! a layer's temperature change to the change in column !! potential energy, including all implicit diffusive changes - !! in the temperatures of all the layers below [J m-2 degC-1]. + !! in the temperatures of all the layers below [R Z L2 T-2 degC-1 ~> J m-2 degC-1]. real, intent(in) :: dS_to_dPE_b !< A factor (pres_lay*mass_lay*dSpec_vol/dS) relating !! a layer's salinity change to the change in column !! potential energy, including all implicit diffusive changes - !! in the salinities of all the layers below [J m-2 ppt-1]. + !! in the salinities of all the layers below [R Z L2 T-2 ppt-1 ~> J m-2 ppt-1]. real, intent(in) :: pres_Z !< The hydrostatic interface pressure, which is used to relate !! the changes in column thickness to the energy that is radiated - !! as gravity waves and unavailable to drive mixing [J m-2 Z-1 ~> J m-3]. + !! as gravity waves and unavailable to drive mixing [R L2 T-2 m Z-1 ~> J m-3]. real, intent(in) :: dT_to_dColHt_a !< A factor (mass_lay*dSColHtc_vol/dT) relating !! a layer's temperature change to the change in column !! height, including all implicit diffusive changes @@ -1031,25 +1030,25 @@ subroutine find_PE_chg(Kddt_h0, dKddt_h, hp_a, hp_b, Th_a, Sh_a, Th_b, Sh_b, & !! in the salinities of all the layers below [Z ppt-1 ~> m ppt-1]. real, optional, intent(out) :: PE_chg !< The change in column potential energy from applying - !! Kddt_h at the present interface [J m-2]. + !! Kddt_h at the present interface [R Z L2 T-2 ~> J m-2]. real, optional, intent(out) :: dPEc_dKd !< The partial derivative of PE_chg with Kddt_h, - !! [J m-2 H-1 ~> J m-3 or J kg-1]. + !! [R Z L2 T-2 H-1 ~> J m-3 or J kg-1]. real, optional, intent(out) :: dPE_max !< The maximum change in column potential energy that could !! be realizedd by applying a huge value of Kddt_h at the - !! present interface [J m-2]. + !! present interface [R Z L2 T-2 ~> J m-2]. real, optional, intent(out) :: dPEc_dKd_0 !< The partial derivative of PE_chg with Kddt_h in the - !! limit where Kddt_h = 0 [J m-2 H-1 ~> J m-3 or J kg-1]. + !! limit where Kddt_h = 0 [R Z L2 T-2 H-1 ~> J m-3 or J kg-1]. real, optional, intent(out) :: ColHt_cor !< The correction to PE_chg that is made due to a net - !! change in the column height [J m-2]. + !! change in the column height [R Z L2 T-2 ~> J m-2]. real :: hps ! The sum of the two effective pivot thicknesses [H ~> m or kg m-2]. real :: bdt1 ! A product of the two pivot thicknesses plus a diffusive term [H2 ~> m2 or kg2 m-4]. real :: dT_c ! The core term in the expressions for the temperature changes [degC H2 ~> degC m2 or degC kg2 m-4]. real :: dS_c ! The core term in the expressions for the salinity changes [psu H2 ~> psu m2 or psu kg2 m-4]. real :: PEc_core ! The diffusivity-independent core term in the expressions - ! for the potential energy changes [J m-3]. + ! for the potential energy changes [R L2 T-2 ~> J m-3]. real :: ColHt_core ! The diffusivity-independent core term in the expressions - ! for the column height changes [J m-3]. + ! for the column height changes [R L2 T-2 ~> J m-3]. real :: ColHt_chg ! The change in the column height [Z ~> m]. real :: y1 ! A local temporary term, in [H-3] or [H-4] in various contexts. @@ -1136,23 +1135,23 @@ subroutine find_PE_chg_orig(Kddt_h, h_k, b_den_1, dTe_term, dSe_term, & !! salinity change in the layer above the interface [ppt]. real, intent(in) :: pres_Z !< The hydrostatic interface pressure, which is used to relate !! the changes in column thickness to the energy that is radiated - !! as gravity waves and unavailable to drive mixing [J m-2 Z-1 ~> J m-3]. + !! as gravity waves and unavailable to drive mixing [R L2 T-2 ~> J m-3]. real, intent(in) :: dT_to_dPE_k !< A factor (pres_lay*mass_lay*dSpec_vol/dT) relating !! a layer's temperature change to the change in column !! potential energy, including all implicit diffusive changes - !! in the temperatures of all the layers below [J m-2 degC-1]. + !! in the temperatures of all the layers below [R Z L2 T-2 degC-1 ~> J m-2 degC-1]. real, intent(in) :: dS_to_dPE_k !< A factor (pres_lay*mass_lay*dSpec_vol/dS) relating !! a layer's salinity change to the change in column !! potential energy, including all implicit diffusive changes - !! in the salinities of all the layers below [J m-2 ppt-1]. + !! in the salinities of all the layers below [R Z L2 T-2 ppt-1 ~> J m-2 ppt-1]. real, intent(in) :: dT_to_dPEa !< A factor (pres_lay*mass_lay*dSpec_vol/dT) relating !! a layer's temperature change to the change in column !! potential energy, including all implicit diffusive changes - !! in the temperatures of all the layers above [J m-2 degC-1]. + !! in the temperatures of all the layers above [R Z L2 T-2 degC-1 ~> J m-2 degC-1]. real, intent(in) :: dS_to_dPEa !< A factor (pres_lay*mass_lay*dSpec_vol/dS) relating !! a layer's salinity change to the change in column !! potential energy, including all implicit diffusive changes - !! in the salinities of all the layers above [J m-2 ppt-1]. + !! in the salinities of all the layers above [R Z L2 T-2 ppt-1 ~> J m-2 ppt-1]. real, intent(in) :: dT_to_dColHt_k !< A factor (mass_lay*dSColHtc_vol/dT) relating !! a layer's temperature change to the change in column !! height, including all implicit diffusive changes @@ -1171,14 +1170,14 @@ subroutine find_PE_chg_orig(Kddt_h, h_k, b_den_1, dTe_term, dSe_term, & !! in the salinities of all the layers above [Z ppt-1 ~> m ppt-1]. real, optional, intent(out) :: PE_chg !< The change in column potential energy from applying - !! Kddt_h at the present interface [J m-2]. + !! Kddt_h at the present interface [R Z L2 T-2 ~> J m-2]. real, optional, intent(out) :: dPEc_dKd !< The partial derivative of PE_chg with Kddt_h, - !! [J m-2 H-1 ~> J m-3 or J kg-1]. + !! [R Z L2 T-2 H-1 ~> J m-3 or J kg-1]. real, optional, intent(out) :: dPE_max !< The maximum change in column potential energy that could !! be realized by applying a huge value of Kddt_h at the - !! present interface [J m-2]. + !! present interface [R Z L2 T-2 ~> J m-2]. real, optional, intent(out) :: dPEc_dKd_0 !< The partial derivative of PE_chg with Kddt_h in the - !! limit where Kddt_h = 0 [J m-2 H-1 ~> J m-3 or J kg-1]. + !! limit where Kddt_h = 0 [R Z L2 T-2 H-1 ~> J m-3 or J kg-1]. ! This subroutine determines the total potential energy change due to mixing ! at an interface, including all of the implicit effects of the prescribed @@ -1302,13 +1301,17 @@ subroutine diapyc_energy_req_init(Time, G, GV, US, param_file, diag, CS) "place of any that might be passed in as an argument.", default=.false.) CS%id_ERt = register_diag_field('ocean_model', 'EnReqTest_ERt', diag%axesZi, Time, & - "Diffusivity Energy Requirements, top-down", "J m-2") + "Diffusivity Energy Requirements, top-down", & + "J m-2", conversion=US%RZ_to_kg_m2*US%L_T_to_m_s**2) CS%id_ERb = register_diag_field('ocean_model', 'EnReqTest_ERb', diag%axesZi, Time, & - "Diffusivity Energy Requirements, bottom-up", "J m-2") + "Diffusivity Energy Requirements, bottom-up", & + "J m-2", conversion=US%RZ_to_kg_m2*US%L_T_to_m_s**2) CS%id_ERc = register_diag_field('ocean_model', 'EnReqTest_ERc', diag%axesZi, Time, & - "Diffusivity Energy Requirements, center-last", "J m-2") + "Diffusivity Energy Requirements, center-last", & + "J m-2", conversion=US%RZ_to_kg_m2*US%L_T_to_m_s**2) CS%id_ERh = register_diag_field('ocean_model', 'EnReqTest_ERh', diag%axesZi, Time, & - "Diffusivity Energy Requirements, halves", "J m-2") + "Diffusivity Energy Requirements, halves", & + "J m-2", conversion=US%RZ_to_kg_m2*US%L_T_to_m_s**2) CS%id_Kddt = register_diag_field('ocean_model', 'EnReqTest_Kddt', diag%axesZi, Time, & "Implicit diffusive coupling coefficient", "m", conversion=GV%H_to_m) CS%id_Kd = register_diag_field('ocean_model', 'EnReqTest_Kd', diag%axesZi, Time, & @@ -1318,13 +1321,17 @@ subroutine diapyc_energy_req_init(Time, G, GV, US, param_file, diag, CS) CS%id_zInt = register_diag_field('ocean_model', 'EnReqTest_z_int', diag%axesZi, Time, & "Test column layer interface heights", "m", conversion=GV%H_to_m) CS%id_CHCt = register_diag_field('ocean_model', 'EnReqTest_CHCt', diag%axesZi, Time, & - "Column Height Correction to Energy Requirements, top-down", "J m-2") + "Column Height Correction to Energy Requirements, top-down", & + "J m-2", conversion=US%RZ_to_kg_m2*US%L_T_to_m_s**2) CS%id_CHCb = register_diag_field('ocean_model', 'EnReqTest_CHCb', diag%axesZi, Time, & - "Column Height Correction to Energy Requirements, bottom-up", "J m-2") + "Column Height Correction to Energy Requirements, bottom-up", & + "J m-2", conversion=US%RZ_to_kg_m2*US%L_T_to_m_s**2) CS%id_CHCc = register_diag_field('ocean_model', 'EnReqTest_CHCc', diag%axesZi, Time, & - "Column Height Correction to Energy Requirements, center-last", "J m-2") + "Column Height Correction to Energy Requirements, center-last", & + "J m-2", conversion=US%RZ_to_kg_m2*US%L_T_to_m_s**2) CS%id_CHCh = register_diag_field('ocean_model', 'EnReqTest_CHCh', diag%axesZi, Time, & - "Column Height Correction to Energy Requirements, halves", "J m-2") + "Column Height Correction to Energy Requirements, halves", & + "J m-2", conversion=US%RZ_to_kg_m2*US%L_T_to_m_s**2) CS%id_T0 = register_diag_field('ocean_model', 'EnReqTest_T0', diag%axesZL, Time, & "Temperature before mixing", "deg C") CS%id_Tf = register_diag_field('ocean_model', 'EnReqTest_Tf', diag%axesZL, Time, & From 500c9e3134eba614eb3acb1a25982b2e89045705 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Mon, 13 Apr 2020 07:06:12 -0400 Subject: [PATCH 172/316] Rescaled pressures in 17 calculate_density calls Rescaled pressures in 17 calculate_density or related calls and internal pressure variables in MOM_diabatic_aux. All answers are bitwise identical. --- src/core/MOM_forcing_type.F90 | 19 +++----- .../lateral/MOM_mixed_layer_restrat.F90 | 19 ++++---- .../lateral/MOM_thickness_diffuse.F90 | 24 +++++----- .../vertical/MOM_diabatic_aux.F90 | 45 ++++++++----------- .../vertical/MOM_set_diffusivity.F90 | 10 ++--- .../vertical/MOM_set_viscosity.F90 | 18 ++++---- 6 files changed, 62 insertions(+), 73 deletions(-) diff --git a/src/core/MOM_forcing_type.F90 b/src/core/MOM_forcing_type.F90 index 80753e0614..652ca5278c 100644 --- a/src/core/MOM_forcing_type.F90 +++ b/src/core/MOM_forcing_type.F90 @@ -851,10 +851,7 @@ subroutine extractFluxes2d(G, GV, US, fluxes, optics, nsw, dt, FluxRescaleDepth, logical, intent(in) :: aggregate_FW !< For determining how to aggregate the forcing. integer :: j -!$OMP parallel do default(none) shared(G, GV, US, fluxes, optics, nsw, dt, FluxRescaleDepth, & -!$OMP useRiverHeatContent, useCalvingHeatContent, & -!$OMP h,T,netMassInOut,netMassOut,Net_heat,Net_salt,Pen_SW_bnd,tv, & -!$OMP aggregate_FW) + !$OMP parallel do default(shared) do j=G%jsc, G%jec call extractFluxes1d(G, GV, US, fluxes, optics, nsw, j, dt, & FluxRescaleDepth, useRiverHeatContent, useCalvingHeatContent,& @@ -891,7 +888,7 @@ subroutine calculateBuoyancyFlux1d(G, GV, US, fluxes, optics, nsw, h, Temp, Salt logical, optional, intent(in) :: skip_diags !< If present and true, skip calculating !! diagnostics inside extractFluxes1d() ! local variables - integer :: start, npts, k + integer :: k real, parameter :: dt = 1. ! to return a rate from extractFluxes1d real, dimension(SZI_(G)) :: netH ! net FW flux [H s-1 ~> m s-1 or kg m-2 s-1] real, dimension(SZI_(G)) :: netEvap ! net FW flux leaving ocean via evaporation @@ -899,7 +896,7 @@ subroutine calculateBuoyancyFlux1d(G, GV, US, fluxes, optics, nsw, h, Temp, Salt real, dimension(SZI_(G)) :: netHeat ! net temp flux [degC H s-1 ~> degC m s-2 or degC kg m-2 s-1] real, dimension(max(nsw,1), SZI_(G)) :: penSWbnd ! penetrating SW radiation by band ! [degC H ~> degC m or degC kg m-2] - real, dimension(SZI_(G)) :: pressure ! pressurea the surface [Pa] + real, dimension(SZI_(G)) :: pressure ! pressure at the surface [R L2 T-2 ~> Pa] real, dimension(SZI_(G)) :: dRhodT ! density partial derivative wrt temp [R degC-1 ~> kg m-3 degC-1] real, dimension(SZI_(G)) :: dRhodS ! density partial derivative wrt saln [R ppt-1 ~> kg m-3 ppt-1] real, dimension(SZI_(G),SZK_(G)+1) :: netPen ! The net penetrating shortwave radiation at each level @@ -917,10 +914,8 @@ subroutine calculateBuoyancyFlux1d(G, GV, US, fluxes, optics, nsw, h, Temp, Salt useCalvingHeatContent = .False. depthBeforeScalingFluxes = max( GV%Angstrom_H, 1.e-30*GV%m_to_H ) - pressure(:) = 0. ! Ignore atmospheric pressure + pressure(:) = 0. ! Ignores atmospheric pressure ### GoRho = (GV%g_Earth * GV%H_to_Z*US%T_to_s) / GV%Rho0 - start = 1 + G%isc - G%isd - npts = 1 + G%iec - G%isc H_limit_fluxes = depthBeforeScalingFluxes @@ -931,7 +926,7 @@ subroutine calculateBuoyancyFlux1d(G, GV, US, fluxes, optics, nsw, h, Temp, Salt ! netSalt = salt via surface fluxes [ppt H s-1 ~> ppt m s-1 or gSalt m-2 s-1] ! Note that unlike other calls to extractFLuxes1d() that return the time-integrated flux ! this call returns the rate because dt=1 - call extractFluxes1d(G, GV, US, fluxes, optics, nsw, j, dt*US%s_to_T, & + call extractFluxes1d(G, GV, US, fluxes, optics, nsw, j, dt*US%s_to_T, & depthBeforeScalingFluxes, useRiverHeatContent, useCalvingHeatContent, & h(:,j,:), Temp(:,j,:), netH, netEvap, netHeatMinusSW, & netSalt, penSWbnd, tv, .false., skip_diags=skip_diags) @@ -942,8 +937,8 @@ subroutine calculateBuoyancyFlux1d(G, GV, US, fluxes, optics, nsw, h, Temp, Salt H_limit_fluxes, .true., penSWbnd, netPen) ! Density derivatives - call calculate_density_derivs(Temp(:,j,1), Salt(:,j,1), pressure, & - dRhodT, dRhodS, start, npts, tv%eqn_of_state, scale=US%kg_m3_to_R) + call calculate_density_derivs(Temp(:,j,1), Salt(:,j,1), pressure, dRhodT, dRhodS, G%HI, & + tv%eqn_of_state, US) ! Adjust netSalt to reflect dilution effect of FW flux netSalt(G%isc:G%iec) = netSalt(G%isc:G%iec) - Salt(G%isc:G%iec,j,1) * netH(G%isc:G%iec) ! ppt H/s diff --git a/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 b/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 index c535cc9334..744a801391 100644 --- a/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 +++ b/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 @@ -149,7 +149,7 @@ subroutine mixedlayer_restrat_general(h, uhtr, vhtr, tv, forces, dt, MLD_in, Var Rml_av_slow ! g_Rho0 times the average mixed layer density [L2 Z-1 T-2 ~> m s-2] real :: g_Rho0 ! G_Earth/Rho0 [L2 Z-1 T-2 R-1 ~> m4 s-2 kg-1] real :: rho_ml(SZI_(G)) ! Potential density relative to the surface [R ~> kg m-3] - real :: p0(SZI_(G)) ! A pressure of 0 [Pa] + real :: p0(SZI_(G)) ! A pressure of 0 [R L2 T-2 ~> Pa] real :: h_vel ! htot interpolated onto velocity points [Z ~> m] (not H). real :: absf ! absolute value of f, interpolated to velocity points [T-1 ~> s-1] @@ -176,7 +176,8 @@ subroutine mixedlayer_restrat_general(h, uhtr, vhtr, tv, forces, dt, MLD_in, Var integer :: i, j, k, is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz real, dimension(SZI_(G)) :: rhoSurf, deltaRhoAtKm1, deltaRhoAtK ! Densities [R ~> kg m-3] real, dimension(SZI_(G)) :: dK, dKm1 ! Depths of layer centers [H ~> m or kg m-2]. - real, dimension(SZI_(G)) :: pRef_MLD ! A reference pressure for calculating the mixed layer densities [Pa]. + real, dimension(SZI_(G)) :: pRef_MLD ! A reference pressure for calculating the mixed layer + ! densities [R L2 T-2 ~> Pa]. real, dimension(SZI_(G)) :: rhoAtK, rho1, d1, pRef_N2 ! Used for N2 real :: aFac, bFac ! Nondimensional ratios [nondim] real :: ddRho ! A density difference [R ~> kg m-3] @@ -206,8 +207,8 @@ subroutine mixedlayer_restrat_general(h, uhtr, vhtr, tv, forces, dt, MLD_in, Var pRef_MLD(:) = 0. do j = js-1, je+1 dK(:) = 0.5 * h(:,j,1) ! Depth of center of surface layer - call calculate_density(tv%T(:,j,1), tv%S(:,j,1), pRef_MLD, rhoSurf, is-1, ie-is+3, & - tv%eqn_of_state, scale=US%kg_m3_to_R) + call calculate_density(tv%T(:,j,1), tv%S(:,j,1), pRef_MLD, rhoSurf, G%HI, & + tv%eqn_of_state, US, halo=1) deltaRhoAtK(:) = 0. MLD_fast(:,j) = 0. do k = 2, nz @@ -215,8 +216,8 @@ subroutine mixedlayer_restrat_general(h, uhtr, vhtr, tv, forces, dt, MLD_in, Var dK(:) = dK(:) + 0.5 * ( h(:,j,k) + h(:,j,k-1) ) ! Depth of center of layer K ! Mixed-layer depth, using sigma-0 (surface reference pressure) deltaRhoAtKm1(:) = deltaRhoAtK(:) ! Store value from previous iteration of K - call calculate_density(tv%T(:,j,k), tv%S(:,j,k), pRef_MLD, deltaRhoAtK, is-1, ie-is+3, & - tv%eqn_of_state, scale=US%kg_m3_to_R) + call calculate_density(tv%T(:,j,k), tv%S(:,j,k), pRef_MLD, deltaRhoAtK, G%HI, & + tv%eqn_of_state, US, halo=1) do i = is-1,ie+1 deltaRhoAtK(i) = deltaRhoAtK(i) - rhoSurf(i) ! Density difference between layer K and surface enddo @@ -321,7 +322,7 @@ subroutine mixedlayer_restrat_general(h, uhtr, vhtr, tv, forces, dt, MLD_in, Var h_avail(i,j,k) = max(I4dt*G%areaT(i,j)*(h(i,j,k)-GV%Angstrom_H),0.0) enddo if (keep_going) then - call calculate_density(tv%T(:,j,k),tv%S(:,j,k),p0,rho_ml(:),is-1,ie-is+3,tv%eqn_of_state, scale=US%kg_m3_to_R) + call calculate_density(tv%T(:,j,k), tv%S(:,j,k), p0, rho_ml(:), G%HI, tv%eqn_of_state, US, halo=1) line_is_empty = .true. do i=is-1,ie+1 if (htot_fast(i,j) < MLD_fast(i,j)) then @@ -585,7 +586,7 @@ subroutine mixedlayer_restrat_BML(h, uhtr, vhtr, tv, forces, dt, G, GV, US, CS) Rml_av ! g_Rho0 times the average mixed layer density [L2 Z-1 T-2 ~> m s-2] real :: g_Rho0 ! G_Earth/Rho0 [L2 Z-1 T-2 R-1 ~> m4 s-2 kg-1] real :: Rho0(SZI_(G)) ! Potential density relative to the surface [R ~> kg m-3] - real :: p0(SZI_(G)) ! A pressure of 0 [Pa] + real :: p0(SZI_(G)) ! A pressure of 0 [R L2 T-2 ~> Pa] real :: h_vel ! htot interpolated onto velocity points [Z ~> m]. (The units are not H.) real :: absf ! absolute value of f, interpolated to velocity points [T-1 ~> s-1] @@ -645,7 +646,7 @@ subroutine mixedlayer_restrat_BML(h, uhtr, vhtr, tv, forces, dt, G, GV, US, CS) htot(i,j) = 0.0 ; Rml_av(i,j) = 0.0 enddo do k=1,nkml - call calculate_density(tv%T(:,j,k),tv%S(:,j,k),p0,Rho0(:),is-1,ie-is+3,tv%eqn_of_state, scale=US%kg_m3_to_R) + call calculate_density(tv%T(:,j,k), tv%S(:,j,k), p0, Rho0(:), G%HI, tv%eqn_of_state, US, halo=1) do i=is-1,ie+1 Rml_av(i,j) = Rml_av(i,j) + h(i,j,k)*Rho0(i) htot(i,j) = htot(i,j) + h(i,j,k) diff --git a/src/parameterizations/lateral/MOM_thickness_diffuse.F90 b/src/parameterizations/lateral/MOM_thickness_diffuse.F90 index 4da62ed5df..453a71467b 100644 --- a/src/parameterizations/lateral/MOM_thickness_diffuse.F90 +++ b/src/parameterizations/lateral/MOM_thickness_diffuse.F90 @@ -594,7 +594,7 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV hN2_x_PE ! thickness in m times Brunt-Vaisala freqeuncy at u-points [L2 Z-1 T-2 ~> m s-2], ! used for calculating PE release real, dimension(SZI_(G), SZJ_(G), SZK_(G)+1) :: & - pres, & ! The pressure at an interface [Pa]. + pres, & ! The pressure at an interface [R L2 T-2 ~> Pa]. h_avail_rsum ! The running sum of h_avail above an interface [H L2 T-1 ~> m3 s-1 or kg s-1]. real, dimension(SZIB_(G)) :: & drho_dT_u, & ! The derivative of density with temperature at u points [R degC-1 ~> kg m-3 degC-1] @@ -607,11 +607,11 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV real, dimension(SZIB_(G)) :: & T_u, & ! Temperature on the interface at the u-point [degC]. S_u, & ! Salinity on the interface at the u-point [ppt]. - pres_u ! Pressure on the interface at the u-point [Pa]. + pres_u ! Pressure on the interface at the u-point [R L2 T-2 ~> Pa]. real, dimension(SZI_(G)) :: & T_v, & ! Temperature on the interface at the v-point [degC]. S_v, & ! Salinity on the interface at the v-point [ppt]. - pres_v ! Pressure on the interface at the v-point [Pa]. + pres_v ! Pressure on the interface at the v-point [R L2 T-2 ~> Pa]. real :: Work_u(SZIB_(G), SZJ_(G)) ! The work being done by the thickness real :: Work_v(SZI_(G), SZJB_(G)) ! diffusion integrated over a cell [R Z L4 T-3 ~> W ] real :: Work_h ! The work averaged over an h-cell [R Z L2 T-3 ~> W m-2]. @@ -720,7 +720,7 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV h_avail(i,j,1) = max(I4dt*G%areaT(i,j)*(h(i,j,1)-GV%Angstrom_H),0.0) h_avail_rsum(i,j,2) = h_avail(i,j,1) h_frac(i,j,1) = 1.0 - pres(i,j,2) = pres(i,j,1) + GV%H_to_Pa*h(i,j,1) + pres(i,j,2) = pres(i,j,1) + (GV%g_Earth*GV%H_to_RZ) * h(i,j,1) enddo ; enddo !$OMP do do j=js-1,je+1 @@ -729,7 +729,7 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV h_avail_rsum(i,j,k+1) = h_avail_rsum(i,j,k) + h_avail(i,j,k) h_frac(i,j,k) = 0.0 ; if (h_avail(i,j,k) > 0.0) & h_frac(i,j,k) = h_avail(i,j,k) / h_avail_rsum(i,j,k+1) - pres(i,j,K+1) = pres(i,j,K) + GV%H_to_Pa*h(i,j,k) + pres(i,j,K+1) = pres(i,j,K) + (GV%g_Earth*GV%H_to_RZ) * h(i,j,k) enddo ; enddo enddo !$OMP do @@ -778,7 +778,7 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV S_u(I) = 0.25*((S(i,j,k) + S(i+1,j,k)) + (S(i,j,k-1) + S(i+1,j,k-1))) enddo call calculate_density_derivs(T_u, S_u, pres_u, drho_dT_u, & - drho_dS_u, (is-IsdB+1)-1, ie-is+2, tv%eqn_of_state, scale=US%kg_m3_to_R) + drho_dS_u, (is-IsdB+1)-1, ie-is+2, tv%eqn_of_state, US=US) endif do I=is-1,ie @@ -1028,8 +1028,8 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV T_v(i) = 0.25*((T(i,j,k) + T(i,j+1,k)) + (T(i,j,k-1) + T(i,j+1,k-1))) S_v(i) = 0.25*((S(i,j,k) + S(i,j+1,k)) + (S(i,j,k-1) + S(i,j+1,k-1))) enddo - call calculate_density_derivs(T_v, S_v, pres_v, drho_dT_v, & - drho_dS_v, is, ie-is+1, tv%eqn_of_state, scale=US%kg_m3_to_R) + call calculate_density_derivs(T_v, S_v, pres_v, drho_dT_v, drho_dS_v, G%HI, & + tv%eqn_of_state, US) endif do i=is,ie if (calc_derivatives) then @@ -1260,8 +1260,8 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV T_u(I) = 0.5*(T(i,j,1) + T(i+1,j,1)) S_u(I) = 0.5*(S(i,j,1) + S(i+1,j,1)) enddo - call calculate_density_derivs(T_u, S_u, pres_u, drho_dT_u, & - drho_dS_u, (is-IsdB+1)-1, ie-is+2, tv%eqn_of_state, scale=US%kg_m3_to_R) + call calculate_density_derivs(T_u, S_u, pres_u, drho_dT_u, drho_dS_u, & + (is-IsdB+1)-1, ie-is+2, tv%eqn_of_state, US=US) endif do I=is-1,ie uhD(I,j,1) = -uhtot(I,j) @@ -1290,8 +1290,8 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV T_v(i) = 0.5*(T(i,j,1) + T(i,j+1,1)) S_v(i) = 0.5*(S(i,j,1) + S(i,j+1,1)) enddo - call calculate_density_derivs(T_v, S_v, pres_v, drho_dT_v, & - drho_dS_v, is, ie-is+1, tv%eqn_of_state, scale=US%kg_m3_to_R) + call calculate_density_derivs(T_v, S_v, pres_v, drho_dT_v, drho_dS_v, G%HI, & + tv%eqn_of_state, US) endif do i=is,ie vhD(i,J,1) = -vhtot(i,J) diff --git a/src/parameterizations/vertical/MOM_diabatic_aux.F90 b/src/parameterizations/vertical/MOM_diabatic_aux.F90 index 55667085ea..4150c82828 100644 --- a/src/parameterizations/vertical/MOM_diabatic_aux.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_aux.F90 @@ -518,9 +518,9 @@ subroutine triDiagTS(G, GV, is, ie, js, je, hold, ea, eb, T, S) real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: hold !< The layer thicknesses before entrainment, !! [H ~> m or kg m-2]. real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: ea !< The amount of fluid entrained from the layer - !! above within this time step [H ~> m or kg m-2]. + !! above within this time step [H ~> m or kg m-2] real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: eb !< The amount of fluid entrained from the layer - !! below within this time step [H ~> m or kg m-2]. + !! below within this time step [H ~> m or kg m-2] real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(inout) :: T !< Layer potential temperatures [degC]. real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(inout) :: S !< Layer salinities [ppt]. @@ -737,7 +737,7 @@ subroutine diagnoseMLDbyDensityDifference(id_MLD, h, tv, densityDiff, G, GV, US, ! Local variables real, dimension(SZI_(G)) :: deltaRhoAtKm1, deltaRhoAtK ! Density differences [R ~> kg m-3]. - real, dimension(SZI_(G)) :: pRef_MLD, pRef_N2 ! Reference pressures [Pa]. + real, dimension(SZI_(G)) :: pRef_MLD, pRef_N2 ! Reference pressures [R L2 T-2 ~> Pa]. real, dimension(SZI_(G)) :: H_subML, dH_N2 ! Summed thicknesses used in N2 calculation [H ~> m]. real, dimension(SZI_(G)) :: T_subML, T_deeper ! Temperatures used in the N2 calculation [degC]. real, dimension(SZI_(G)) :: S_subML, S_deeper ! Salinities used in the N2 calculation [ppt]. @@ -767,8 +767,7 @@ subroutine diagnoseMLDbyDensityDifference(id_MLD, h, tv, densityDiff, G, GV, US, pRef_MLD(:) = 0.0 do j=js,je do i=is,ie ; dK(i) = 0.5 * h(i,j,1) * GV%H_to_Z ; enddo ! Depth of center of surface layer - call calculate_density(tv%T(:,j,1), tv%S(:,j,1), pRef_MLD, rhoSurf, is, ie-is+1, & - tv%eqn_of_state, scale=US%kg_m3_to_R) + call calculate_density(tv%T(:,j,1), tv%S(:,j,1), pRef_MLD, rhoSurf, G%HI, tv%eqn_of_state, US) do i=is,ie deltaRhoAtK(i) = 0. MLD(i,j) = 0. @@ -809,8 +808,7 @@ subroutine diagnoseMLDbyDensityDifference(id_MLD, h, tv, densityDiff, G, GV, US, ! Mixed-layer depth, using sigma-0 (surface reference pressure) do i=is,ie ; deltaRhoAtKm1(i) = deltaRhoAtK(i) ; enddo ! Store value from previous iteration of K - call calculate_density(tv%T(:,j,k), tv%S(:,j,k), pRef_MLD, deltaRhoAtK, is, ie-is+1, & - tv%eqn_of_state, scale=US%kg_m3_to_R) + call calculate_density(tv%T(:,j,k), tv%S(:,j,k), pRef_MLD, deltaRhoAtK, G%HI, tv%eqn_of_state, US) do i = is, ie deltaRhoAtK(i) = deltaRhoAtK(i) - rhoSurf(i) ! Density difference between layer K and surface ddRho = deltaRhoAtK(i) - deltaRhoAtKm1(i) @@ -827,16 +825,14 @@ subroutine diagnoseMLDbyDensityDifference(id_MLD, h, tv, densityDiff, G, GV, US, enddo if (id_N2>0) then ! Now actually calculate stratification, N2, below the mixed layer. - do i=is,ie ; pRef_N2(i) = GV%H_to_Pa * (H_subML(i) + 0.5*dH_N2(i)) ; enddo + do i=is,ie ; pRef_N2(i) = (GV%g_Earth * GV%H_to_RZ) * (H_subML(i) + 0.5*dH_N2(i)) ; enddo ! if ((.not.N2_region_set(i)) .and. (dH_N2(i) > 0.5*dH_subML)) then ! ! Use whatever stratification we can, measured over whatever distance is available? ! T_deeper(i) = tv%T(i,j,nz) ; S_deeper(i) = tv%S(i,j,nz) ! N2_region_set(i) = .true. ! endif - call calculate_density(T_subML, S_subML, pRef_N2, rho_subML, is, ie-is+1, & - tv%eqn_of_state, scale=US%kg_m3_to_R) - call calculate_density(T_deeper, S_deeper, pRef_N2, rho_deeper, is, ie-is+1, & - tv%eqn_of_state, scale=US%kg_m3_to_R) + call calculate_density(T_subML, S_subML, pRef_N2, rho_subML, G%HI, tv%eqn_of_state, US) + call calculate_density(T_deeper, S_deeper, pRef_N2, rho_deeper, G%HI, tv%eqn_of_state, US) do i=is,ie ; if ((G%mask2dT(i,j)>0.5) .and. N2_region_set(i)) then subMLN2(i,j) = gE_rho0 * (rho_deeper(i) - rho_subML(i)) / (GV%H_to_z * dH_N2(i)) endif ; enddo @@ -897,9 +893,9 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t real :: RivermixConst ! A constant used in implementing river mixing [R Z2 T-1 ~> Pa s]. real, dimension(SZI_(G)) :: & - d_pres, & ! pressure change across a layer [Pa] - p_lay, & ! average pressure in a layer [Pa] - pres, & ! pressure at an interface [Pa] + d_pres, & ! pressure change across a layer [R L2 T-2 ~> Pa] + p_lay, & ! average pressure in a layer [R L2 T-2 ~> Pa] + pres, & ! pressure at an interface [R L2 T-2 ~> Pa] netMassInOut, & ! surface water fluxes [H ~> m or kg m-2] over time step netMassIn, & ! mass entering ocean surface [H ~> m or kg m-2] over a time step netMassOut, & ! mass leaving ocean surface [H ~> m or kg m-2] over a time step @@ -909,7 +905,7 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t ! [ppt H ~> ppt m or ppt kg m-2] nonpenSW, & ! non-downwelling SW, which is absorbed at ocean surface ! [degC H ~> degC m or degC kg m-2] - SurfPressure, & ! Surface pressure (approximated as 0.0) [Pa] + SurfPressure, & ! Surface pressure (approximated as 0.0) [R L2 T-2 ~> Pa] dRhodT, & ! change in density per change in temperature [R degC-1 ~> kg m-3 degC-1] dRhodS, & ! change in density per change in salinity [R ppt-1 ~> kg m-3 ppt-1] netheat_rate, & ! netheat but for dt=1 [degC H T-1 ~> degC m s-1 or degC kg m-2 s-1] @@ -942,7 +938,6 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t logical :: calculate_energetics logical :: calculate_buoyancy integer :: i, j, is, ie, js, je, k, nz, n, nb - integer :: start, npts character(len=45) :: mesg is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke @@ -960,10 +955,8 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t if (present(cTKE)) cTKE(:,:,:) = 0.0 if (calculate_buoyancy) then - SurfPressure(:) = 0.0 + SurfPressure(:) = 0.0 !### Add fluxes%p_surf_full? GoRho = US%L_to_Z**2*GV%g_Earth / GV%Rho0 - start = 1 + G%isc - G%isd - npts = 1 + G%iec - G%isc endif ! H_limit_fluxes is used by extractFluxes1d to scale down fluxes if the total @@ -991,7 +984,7 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t !$OMP netmassinout_rate,netheat_rate,netsalt_rate, & !$OMP drhodt,drhods,pen_sw_bnd_rate, & !$OMP pen_TKE_2d,Temp_in,Salin_in,RivermixConst) & - !$OMP firstprivate(start,npts,SurfPressure) + !$OMP firstprivate(SurfPressure) do j=js,je ! Work in vertical slices for efficiency @@ -1006,15 +999,15 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t ! The partial derivatives of specific volume with temperature and ! salinity need to be precalculated to avoid having heating of ! tiny layers give nonsensical values. - do i=is,ie ; pres(i) = 0.0 ; enddo ! Add surface pressure? + do i=is,ie ; pres(i) = 0.0 ; enddo ! ###Add surface pressure? do k=1,nz do i=is,ie - d_pres(i) = GV%H_to_Pa * h2d(i,k) + d_pres(i) = (GV%g_Earth * GV%H_to_RZ) * h2d(i,k) p_lay(i) = pres(i) + 0.5*d_pres(i) pres(i) = pres(i) + d_pres(i) enddo call calculate_specific_vol_derivs(T2d(:,k), tv%S(:,j,k), p_lay(:),& - dSV_dT(:,j,k), dSV_dS(:,j,k), is, ie-is+1, tv%eqn_of_state, scale=US%R_to_kg_m3) + dSV_dT(:,j,k), dSV_dS(:,j,k), is, ie-is+1, tv%eqn_of_state, US=US) do i=is,ie ; dSV_dT_2d(i,k) = dSV_dT(i,j,k) ; enddo enddo pen_TKE_2d(:,:) = 0.0 @@ -1355,8 +1348,8 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t do i=is,ie ; do nb=1,nsw ; netPen_rate(i) = netPen_rate(i) + pen_SW_bnd_rate(nb,i) ; enddo ; enddo ! Density derivatives - call calculate_density_derivs(T2d(:,1), tv%S(:,j,1), SurfPressure, & - dRhodT, dRhodS, start, npts, tv%eqn_of_state, scale=US%kg_m3_to_R) + call calculate_density_derivs(T2d(:,1), tv%S(:,j,1), SurfPressure, dRhodT, dRhodS, G%HI, & + tv%eqn_of_state, US) ! 1. Adjust netSalt to reflect dilution effect of FW flux ! 2. Add in the SW heating for purposes of calculating the net ! surface buoyancy flux affecting the top layer. diff --git a/src/parameterizations/vertical/MOM_set_diffusivity.F90 b/src/parameterizations/vertical/MOM_set_diffusivity.F90 index 03fa62f2f9..b3eeac08c9 100644 --- a/src/parameterizations/vertical/MOM_set_diffusivity.F90 +++ b/src/parameterizations/vertical/MOM_set_diffusivity.F90 @@ -1036,7 +1036,7 @@ subroutine double_diffusion(tv, h, T_f, S_f, j, G, GV, US, CS, Kd_T_dd, Kd_S_dd) real, dimension(SZI_(G)) :: & dRho_dT, & ! partial derivatives of density wrt temp [R degC-1 ~> kg m-3 degC-1] dRho_dS, & ! partial derivatives of density wrt saln [R ppt-1 ~> kg m-3 ppt-1] - pres, & ! pressure at each interface [Pa] + pres, & ! pressure at each interface [R L2 T-2 ~> Pa] Temp_int, & ! temperature at interfaces [degC] Salin_int ! Salinity at interfaces [ppt] @@ -1054,18 +1054,18 @@ subroutine double_diffusion(tv, h, T_f, S_f, j, G, GV, US, CS, Kd_T_dd, Kd_S_dd) is = G%isc ; ie = G%iec ; nz = G%ke if (associated(tv%eqn_of_state)) then - do i=is,ie + do i=is,ie !### Add surface pressure. pres(i) = 0.0 ; Kd_T_dd(i,1) = 0.0 ; Kd_S_dd(i,1) = 0.0 Kd_T_dd(i,nz+1) = 0.0 ; Kd_S_dd(i,nz+1) = 0.0 enddo do K=2,nz do i=is,ie - pres(i) = pres(i) + GV%H_to_Pa*h(i,j,k-1) + pres(i) = pres(i) + (GV%g_Earth*GV%H_to_RZ)*h(i,j,k-1) Temp_Int(i) = 0.5 * (T_f(i,j,k-1) + T_f(i,j,k)) Salin_Int(i) = 0.5 * (S_f(i,j,k-1) + S_f(i,j,k)) enddo - call calculate_density_derivs(Temp_int, Salin_int, pres, & - dRho_dT(:), dRho_dS(:), is, ie-is+1, tv%eqn_of_state, scale=US%kg_m3_to_R) + call calculate_density_derivs(Temp_int, Salin_int, pres, dRho_dT, dRho_dS, G%HI, & + tv%eqn_of_state, US) do i=is,ie alpha_dT = -1.0*dRho_dT(i) * (T_f(i,j,k-1) - T_f(i,j,k)) diff --git a/src/parameterizations/vertical/MOM_set_viscosity.F90 b/src/parameterizations/vertical/MOM_set_viscosity.F90 index da3adc1ac5..f7ae639fa0 100644 --- a/src/parameterizations/vertical/MOM_set_viscosity.F90 +++ b/src/parameterizations/vertical/MOM_set_viscosity.F90 @@ -147,7 +147,7 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, symmetrize) ! layer with temperature [R degC-1 ~> kg m-3 degC-1]. dR_dS, & ! Partial derivative of the density in the bottom boundary ! layer with salinity [R ppt-1 ~> kg m-3 ppt-1]. - press ! The pressure at which dR_dT and dR_dS are evaluated [Pa]. + press ! The pressure at which dR_dT and dR_dS are evaluated [R L2 T-2 ~> Pa]. real :: htot ! Sum of the layer thicknesses up to some point [H ~> m or kg m-2]. real :: htot_vel ! Sum of the layer thicknesses up to some point [H ~> m or kg m-2]. @@ -566,14 +566,14 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, symmetrize) if (use_BBL_EOS) then do i=is,ie - press(i) = 0.0 ! or = forces%p_surf(i,j) + press(i) = 0.0 ! or = forces%p_surf(i) !### if (.not.do_i(i)) then ; T_EOS(i) = 0.0 ; S_EOS(i) = 0.0 ; endif enddo do k=1,nz ; do i=is,ie - press(i) = press(i) + GV%H_to_Pa * h_vel(i,k) + press(i) = press(i) + (GV%H_to_RZ*GV%g_Earth) * h_vel(i,k) enddo ; enddo call calculate_density_derivs(T_EOS, S_EOS, press, dR_dT, dR_dS, & - is-G%IsdB+1, ie-is+1, tv%eqn_of_state, scale=US%kg_m3_to_R) + is-G%IsdB+1, ie-is+1, tv%eqn_of_state, US=US) endif do i=is,ie ; if (do_i(i)) then @@ -1086,7 +1086,7 @@ subroutine set_viscous_ML(u, v, h, tv, forces, visc, dt, G, GV, US, CS, symmetri dR_dS, & ! Partial derivative of the density at the base of layer nkml ! (roughly the base of the mixed layer) with salinity [R ppt-1 ~> kg m-3 ppt-1]. ustar, & ! The surface friction velocity under ice shelves [Z T-1 ~> m s-1]. - press, & ! The pressure at which dR_dT and dR_dS are evaluated [Pa]. + press, & ! The pressure at which dR_dT and dR_dS are evaluated [R L2 T-2 ~> Pa]. T_EOS, & ! The potential temperature at which dR_dT and dR_dS are evaluated [degC] S_EOS ! The salinity at which dR_dT and dR_dS are evaluated [ppt]. real, dimension(SZIB_(G),SZJ_(G)) :: & @@ -1269,14 +1269,14 @@ subroutine set_viscous_ML(u, v, h, tv, forces, visc, dt, G, GV, US, CS, symmetri if (use_EOS .and. (k==nkml+1)) then ! Find dRho/dT and dRho_dS. do I=Isq,Ieq - press(I) = GV%H_to_Pa * htot(I) + press(I) = (GV%H_to_RZ*GV%g_Earth) * htot(I) k2 = max(1,nkml) I_2hlay = 1.0 / (h(i,j,k2) + h(i+1,j,k2) + h_neglect) T_EOS(I) = (h(i,j,k2)*tv%T(i,j,k2) + h(i+1,j,k2)*tv%T(i+1,j,k2)) * I_2hlay S_EOS(I) = (h(i,j,k2)*tv%S(i,j,k2) + h(i+1,j,k2)*tv%S(i+1,j,k2)) * I_2hlay enddo call calculate_density_derivs(T_EOS, S_EOS, press, dR_dT, dR_dS, & - Isq-G%IsdB+1, Ieq-Isq+1, tv%eqn_of_state, scale=US%kg_m3_to_R) + Isq-G%IsdB+1, Ieq-Isq+1, tv%eqn_of_state, US=US) endif do I=Isq,Ieq ; if (do_i(I)) then @@ -1506,14 +1506,14 @@ subroutine set_viscous_ML(u, v, h, tv, forces, visc, dt, G, GV, US, CS, symmetri if (use_EOS .and. (k==nkml+1)) then ! Find dRho/dT and dRho_dS. do i=is,ie - press(i) = GV%H_to_Pa * htot(i) + press(i) = (GV%H_to_RZ * GV%g_Earth) * htot(i) k2 = max(1,nkml) I_2hlay = 1.0 / (h(i,j,k2) + h(i,j+1,k2) + h_neglect) T_EOS(i) = (h(i,j,k2)*tv%T(i,j,k2) + h(i,j+1,k2)*tv%T(i,j+1,k2)) * I_2hlay S_EOS(i) = (h(i,j,k2)*tv%S(i,j,k2) + h(i,j+1,k2)*tv%S(i,j+1,k2)) * I_2hlay enddo call calculate_density_derivs(T_EOS, S_EOS, press, dR_dT, dR_dS, & - is-G%IsdB+1, ie-is+1, tv%eqn_of_state, scale=US%kg_m3_to_R) + is-G%IsdB+1, ie-is+1, tv%eqn_of_state, US=US) endif do i=is,ie ; if (do_i(i)) then From 00db8d5fbb03ac91437b78195a7e862e276ddd8f Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Mon, 13 Apr 2020 08:16:25 -0400 Subject: [PATCH 173/316] Corrected a bug in calculate_spec_vol_derivs_H1_1d Corrected a rescaling bug in calculate_spec_vol_derivs_H1_1d, but as this code was not yet being exercised, there are no answer changes. Also modified applyBoundaryFluxesInOut to use this fixed routine. All answers are bitwise identical. --- src/equation_of_state/MOM_EOS.F90 | 62 ++----------------- .../vertical/MOM_diabatic_aux.F90 | 4 +- 2 files changed, 7 insertions(+), 59 deletions(-) diff --git a/src/equation_of_state/MOM_EOS.F90 b/src/equation_of_state/MOM_EOS.F90 index e4da6df2bc..9e66248cb3 100644 --- a/src/equation_of_state/MOM_EOS.F90 +++ b/src/equation_of_state/MOM_EOS.F90 @@ -1072,11 +1072,7 @@ subroutine calculate_spec_vol_derivs_HI_1d(T, S, pressure, dSV_dT, dSV_dS, HI, E integer, optional, intent(in) :: halo !< The halo size to work on; missing is equivalent to 0. ! Local variables - real, dimension(HI%isd:HI%ied) :: rho ! In situ density [kg m-3] - real, dimension(HI%isd:HI%ied) :: dRho_dT ! Derivative of density with temperature [kg m-3 degC-1] - real, dimension(HI%isd:HI%ied) :: dRho_dS ! Derivative of density with salinity [kg m-3 ppt-1] real, dimension(HI%isd:HI%ied) :: press ! Pressure converted to [Pa] - real :: rho_reference ! rho_ref converted to [kg m-3] integer :: i, is, ie, start, npts, halo_sz if (.not.associated(EOS)) call MOM_error(FATAL, & @@ -1089,63 +1085,15 @@ subroutine calculate_spec_vol_derivs_HI_1d(T, S, pressure, dSV_dT, dSV_dS, HI, E is = HI%isc - halo_sz ; ie = HI%iec + halo_sz if (US%RL2_T2_to_Pa == 1.0) then - select case (EOS%form_of_EOS) - case (EOS_LINEAR) - call calculate_specvol_derivs_linear(T, S, pressure, dSV_dT, dSV_dS, start, & - npts, EOS%Rho_T0_S0, EOS%dRho_dT, EOS%dRho_dS) - case (EOS_UNESCO) - call calculate_density_unesco(T, S, pressure, rho, start, npts) - call calculate_density_derivs_unesco(T, S, pressure, drho_dT, drho_dS, start, npts) - do i=is,ie - dSV_dT(i) = -dRho_DT(i)/(rho(i)**2) - dSV_dS(i) = -dRho_DS(i)/(rho(i)**2) - enddo - case (EOS_WRIGHT) - call calculate_specvol_derivs_wright(T, S, pressure, dSV_dT, dSV_dS, start, npts) - case (EOS_TEOS10) - call calculate_specvol_derivs_teos10(T, S, pressure, dSV_dT, dSV_dS, start, npts) - case (EOS_NEMO) - call calculate_density_nemo(T, S, pressure, rho, start, npts) - call calculate_density_derivs_nemo(T, S, pressure, drho_dT, drho_dS, start, npts) - do i=is,ie - dSV_dT(i) = -dRho_DT(i)/(rho(i)**2) - dSV_dS(i) = -dRho_DS(i)/(rho(i)**2) - enddo - case default - call MOM_error(FATAL, "calculate_spec_vol_derivs_HI_1d: EOS%form_of_EOS is not valid.") - end select + call calculate_spec_vol_derivs_array(T, S, pressure, dSV_dT, dSV_dS, start, npts, EOS) else do i=is,ie ; press(i) = US%RL2_T2_to_Pa * pressure(i) ; enddo - select case (EOS%form_of_EOS) - case (EOS_LINEAR) - call calculate_specvol_derivs_linear(T, S, press, dSV_dT, dSV_dS, start, & - npts, EOS%Rho_T0_S0, EOS%dRho_dT, EOS%dRho_dS) - case (EOS_UNESCO) - call calculate_density_unesco(T, S, press, rho, start, npts) - call calculate_density_derivs_unesco(T, S, press, drho_dT, drho_dS, start, npts) - do i=is,ie - dSV_dT(i) = -dRho_DT(i)/(rho(i)**2) - dSV_dS(i) = -dRho_DS(i)/(rho(i)**2) - enddo - case (EOS_WRIGHT) - call calculate_specvol_derivs_wright(T, S, press, dSV_dT, dSV_dS, start, npts) - case (EOS_TEOS10) - call calculate_specvol_derivs_teos10(T, S, press, dSV_dT, dSV_dS, start, npts) - case (EOS_NEMO) - call calculate_density_nemo(T, S, pressure, rho, start, npts) - call calculate_density_derivs_nemo(T, S, press, drho_dT, drho_dS, start, npts) - do i=is,ie - dSV_dT(i) = -dRho_DT(i)/(rho(i)**2) - dSV_dS(i) = -dRho_DS(i)/(rho(i)**2) - enddo - case default - call MOM_error(FATAL, "calculate_spec_vol_derivs_HI_1d: EOS%form_of_EOS is not valid.") - end select + call calculate_spec_vol_derivs_array(T, S, press, dSV_dT, dSV_dS, start, npts, EOS) endif if (US%R_to_kg_m3 /= 1.0) then ; do i=is,ie - drho_dT(i) = US%R_to_kg_m3 * drho_dT(i) - drho_dS(i) = US%R_to_kg_m3 * drho_dS(i) + dSV_dT(i) = US%R_to_kg_m3 * dSV_dT(i) + dSV_dS(i) = US%R_to_kg_m3 * dSV_dS(i) enddo ; endif end subroutine calculate_spec_vol_derivs_HI_1d @@ -1207,7 +1155,7 @@ subroutine calculate_compress_scalar(T, S, pressure, rho, drho_dp, EOS) end subroutine calculate_compress_scalar -!> Calls the appropriate subroutine to alculate analytical and nearly-analytical +!> Calls the appropriate subroutine to calculate 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 diff --git a/src/parameterizations/vertical/MOM_diabatic_aux.F90 b/src/parameterizations/vertical/MOM_diabatic_aux.F90 index 4150c82828..dc8bbc2409 100644 --- a/src/parameterizations/vertical/MOM_diabatic_aux.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_aux.F90 @@ -1006,8 +1006,8 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t p_lay(i) = pres(i) + 0.5*d_pres(i) pres(i) = pres(i) + d_pres(i) enddo - call calculate_specific_vol_derivs(T2d(:,k), tv%S(:,j,k), p_lay(:),& - dSV_dT(:,j,k), dSV_dS(:,j,k), is, ie-is+1, tv%eqn_of_state, US=US) + call calculate_specific_vol_derivs(T2d(:,k), tv%S(:,j,k), p_lay(:), & + dSV_dT(:,j,k), dSV_dS(:,j,k), G%HI, tv%eqn_of_state, US=US) do i=is,ie ; dSV_dT_2d(i,k) = dSV_dT(i,j,k) ; enddo enddo pen_TKE_2d(:,:) = 0.0 From 2a951e7b7ec5bda1a3e3241e79e44c2d77d85d09 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Mon, 13 Apr 2020 11:57:16 -0400 Subject: [PATCH 174/316] Redirected various EOS interfaces to common code Redirected complicated equation of state routines to all work via the same 1-d array versions of the code. This shortens the MOM_EOS.F90 code even as new routines are added under the same overloaded interfaces. All answers are bitwise identical. --- src/equation_of_state/MOM_EOS.F90 | 434 ++++++++++++------------------ 1 file changed, 165 insertions(+), 269 deletions(-) diff --git a/src/equation_of_state/MOM_EOS.F90 b/src/equation_of_state/MOM_EOS.F90 index 9e66248cb3..82f59ca012 100644 --- a/src/equation_of_state/MOM_EOS.F90 +++ b/src/equation_of_state/MOM_EOS.F90 @@ -64,7 +64,7 @@ module MOM_EOS !> 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, calculate_spec_vol_HI_1d + module procedure calc_spec_vol_scalar, calculate_spec_vol_array, calc_spec_vol_HI_1d, calc_spec_vol_US end interface calculate_spec_vol !> Calculate the derivatives of density with temperature and salinity from T, S, and P @@ -74,7 +74,7 @@ module MOM_EOS end interface calculate_density_derivs interface calculate_specific_vol_derivs - module procedure calculate_spec_vol_derivs_array, calculate_spec_vol_derivs_HI_1d + module procedure calculate_spec_vol_derivs_array, calc_spec_vol_derivs_US, calc_spec_vol_derivs_HI_1d end interface calculate_specific_vol_derivs !> Calculates the second derivatives of density with various combinations of temperature, @@ -280,39 +280,11 @@ subroutine calculate_density_HI_1d(T, S, pressure, rho, HI, EOS, US, halo) npts = HI%iec - HI%isc + 1 + 2*halo_sz is = HI%isc - halo_sz ; ie = HI%iec + halo_sz - if ((US%RL2_T2_to_Pa == 1.0) .and. (US%R_to_kg_M3 == 1.0)) then - 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) - case (EOS_UNESCO) - call calculate_density_unesco(T, S, pressure, rho, start, npts) - case (EOS_WRIGHT) - call calculate_density_wright(T, S, pressure, rho, start, npts) - case (EOS_TEOS10) - call calculate_density_teos10(T, S, pressure, rho, start, npts) - case (EOS_NEMO) - call calculate_density_nemo(T, S, pressure, rho, start, npts) - case default - call MOM_error(FATAL, "calculate_density_HI_1d: EOS%form_of_EOS is not valid.") - end select + if (US%RL2_T2_to_Pa == 1.0) then + call calculate_density_array(T, S, pressure, rho, start, npts, EOS) else ! There is rescaling of variables, including pressure. do i=is,ie ; pres(i) = US%RL2_T2_to_Pa * pressure(i) ; enddo - select case (EOS%form_of_EOS) - case (EOS_LINEAR) - call calculate_density_linear(T, S, pres, rho, start, npts, & - EOS%Rho_T0_S0, EOS%dRho_dT, EOS%dRho_dS) - case (EOS_UNESCO) - call calculate_density_unesco(T, S, pres, rho, start, npts) - case (EOS_WRIGHT) - call calculate_density_wright(T, S, pres, rho, start, npts) - case (EOS_TEOS10) - call calculate_density_teos10(T, S, pres, rho, start, npts) - case (EOS_NEMO) - call calculate_density_nemo(T, S, pres, rho, start, npts) - case default - call MOM_error(FATAL, "calculate_density_HI_1d: EOS%form_of_EOS is not valid.") - end select + call calculate_density_array(T, S, pres, rho, start, npts, EOS) endif if (US%kg_m3_to_R /= 1.0) then ; do i=is,ie @@ -321,48 +293,83 @@ subroutine calculate_density_HI_1d(T, S, pressure, rho, HI, EOS, US, halo) end subroutine calculate_density_HI_1d +!> 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, scale) + real, dimension(:), intent(in) :: T !< potential temperature relative to the surface [degC] + real, dimension(:), intent(in) :: S !< salinity [ppt] + real, dimension(:), intent(in) :: pressure !< pressure [Pa] + real, dimension(:), intent(inout) :: specvol !< in situ specific volume [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 [m3 kg-1] + real, optional, intent(in) :: scale !< A multiplicative factor by which to scale specific + !! volume in combination with scaling given by US [various] + + real, dimension(size(specvol)) :: rho ! Density [kg m-3] + integer :: j + + 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 + + if (present(scale)) then ; if (scale /= 1.0) then ; do j=start,start+npts-1 + specvol(j) = scale * specvol(j) + enddo ; endif ; endif + +end subroutine calculate_spec_vol_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, US, scale) +subroutine calc_spec_vol_scalar(T, S, pressure, specvol, EOS, spv_ref, US, scale) real, intent(in) :: T !< Potential temperature referenced to the surface [degC] real, intent(in) :: S !< Salinity [ppt] real, intent(in) :: pressure !< Pressure [Pa] or [R L2 T-2 ~> Pa] real, intent(out) :: specvol !< In situ? specific volume [m3 kg-1] or [R-1 ~> m3 kg-1] type(EOS_type), pointer :: EOS !< Equation of state structure - real, optional, intent(in) :: spv_ref !< A reference specific volume [m3 kg-1] + real, optional, intent(in) :: spv_ref !< A reference specific volume [m3 kg-1] or [R-1 m3 kg-1] type(unit_scale_type), optional, intent(in) :: US !< A dimensional unit scaling type real, optional, intent(in) :: scale !< A multiplicative factor by which to scale specific !! volume in combination with scaling given by US [various] - real :: p_scale ! A factor to convert pressure to units of Pa [Pa T2 R-1 L-2 ~> 1] - real :: rho ! Density [kg m-3] + real, dimension(1) :: Ta, Sa, pres, spv ! Rescaled single element array versions of the arguments. + real :: spv_reference ! spv_ref converted to [m3 kg-1] real :: spv_scale ! A factor to convert specific volume from m3 kg-1 to the desired units [kg R-1 m-3 ~> 1] if (.not.associated(EOS)) call MOM_error(FATAL, & - "calculate_spec_vol_scalar called with an unassociated EOS_type EOS.") + "calc_spec_vol_scalar called with an unassociated EOS_type EOS.") - p_scale = 1.0 ; if (present(US)) p_scale = US%RL2_T2_to_Pa + pres(1) = pressure ; if (present(US)) pres(1) = US%RL2_T2_to_Pa*pressure + Ta(1) = T ; Sa(1) = S - select case (EOS%form_of_EOS) - case (EOS_LINEAR) - call calculate_spec_vol_linear(T, S, p_scale*pressure, specvol, & - EOS%rho_T0_S0, EOS%drho_dT, EOS%drho_dS, spv_ref) - case (EOS_UNESCO) - call calculate_spec_vol_unesco(T, S, p_scale*pressure, specvol, spv_ref) - case (EOS_WRIGHT) - call calculate_spec_vol_wright(T, S, p_scale*pressure, specvol, spv_ref) - case (EOS_TEOS10) - call calculate_spec_vol_teos10(T, S, p_scale*pressure, specvol, spv_ref) - case (EOS_NEMO) - call calculate_density_nemo(T, S, p_scale*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 + if (present(spv_ref)) then + spv_reference = spv_ref ; if (present(US)) spv_reference = US%kg_m3_to_R*spv_ref + call calculate_spec_vol_array(Ta, Sa, pres, spv, 1, 1, EOS, spv_reference) + else + call calculate_spec_vol_array(Ta, Sa, pres, spv, 1, 1, EOS) + endif + specvol = spv(1) spv_scale = 1.0 ; if (present(US)) spv_scale = US%R_to_kg_m3 if (present(scale)) spv_scale = spv_scale * scale @@ -370,11 +377,11 @@ subroutine calculate_spec_vol_scalar(T, S, pressure, specvol, EOS, spv_ref, US, specvol = spv_scale * specvol endif -end subroutine calculate_spec_vol_scalar +end subroutine calc_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, US, scale) +!! for 1-D array inputs with dimensional rescaling. +subroutine calc_spec_vol_US(T, S, pressure, specvol, start, npts, EOS, US, spv_ref, scale) real, dimension(:), intent(in) :: T !< potential temperature relative to the surface [degC] real, dimension(:), intent(in) :: S !< salinity [ppt] real, dimension(:), intent(in) :: pressure !< pressure [Pa] or [R L2 T-2 ~> Pa] @@ -382,78 +389,45 @@ subroutine calculate_spec_vol_array(T, S, pressure, specvol, start, npts, EOS, s 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 + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real, optional, intent(in) :: spv_ref !< A reference specific volume [m3 kg-1] - type(unit_scale_type), optional, intent(in) :: US !< A dimensional unit scaling type real, optional, intent(in) :: scale !< A multiplicative factor by which to scale specific !! volume in combination with scaling given by US [various] real, dimension(size(pressure)) :: pres ! Pressure converted to [Pa] - real, dimension(size(specvol)) :: rho ! Density [kg m-3] - real :: p_scale ! A factor to convert pressure to units of Pa [Pa T2 R-1 L-2 ~> 1] + real :: spv_reference ! spv_ref converted to [m3 kg-1] real :: spv_scale ! A factor to convert specific volume from m3 kg-1 to the desired units [kg R-1 m-3 ~> 1] - integer :: j + integer :: i, is, ie if (.not.associated(EOS)) call MOM_error(FATAL, & "calculate_spec_vol_array called with an unassociated EOS_type EOS.") - p_scale = 1.0 ; if (present(US)) p_scale = US%RL2_T2_to_Pa + is = start ; ie = is + npts - 1 - if (p_scale == 1.0) then - 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 - else - do j=start,start+npts-1 ; pres(j) = p_scale * pressure(j) ; enddo - select case (EOS%form_of_EOS) - case (EOS_LINEAR) - call calculate_spec_vol_linear(T, S, pres, 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, pres, specvol, start, npts, spv_ref) - case (EOS_WRIGHT) - call calculate_spec_vol_wright(T, S, pres, specvol, start, npts, spv_ref) - case (EOS_TEOS10) - call calculate_spec_vol_teos10(T, S, pres, specvol, start, npts, spv_ref) - case (EOS_NEMO) - call calculate_density_nemo(T, S, pres, 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 + if ((US%RL2_T2_to_Pa == 1.0) .and. (US%R_to_kg_m3 == 1.0)) then + call calculate_spec_vol_array(T, S, pressure, specvol, start, npts, EOS, spv_ref) + elseif (present(spv_ref)) then ! This is the same as above, but with some extra work to rescale variables. + do i=is,ie ; pres(i) = US%RL2_T2_to_Pa * pressure(i) ; enddo + spv_reference = US%kg_m3_to_R*spv_ref + call calculate_spec_vol_array(T, S, pres, specvol, start, npts, EOS, spv_reference) + else ! There is rescaling of variables, but spv_ref is not present. Passing a 0 value of spv_ref + ! changes answers at roundoff for some equations of state, like Wright and UNESCO. + do i=is,ie ; pres(i) = US%RL2_T2_to_Pa * pressure(i) ; enddo + call calculate_spec_vol_array(T, S, pres, specvol, start, npts, EOS) endif - spv_scale = 1.0 ; if (present(US)) spv_scale = US%R_to_kg_m3 + spv_scale = US%R_to_kg_m3 if (present(scale)) spv_scale = spv_scale * scale - if (spv_scale /= 1.0) then ; do j=start,start+npts-1 - specvol(j) = spv_scale * specvol(j) + if (spv_scale /= 1.0) then ; do i=is,ie + specvol(i) = spv_scale * specvol(i) enddo ; endif -end subroutine calculate_spec_vol_array +end subroutine calc_spec_vol_US + !> Calls the appropriate subroutine to calculate the specific volume of sea water for 1-D array !! inputs using array extents determined from a hor_index_type. -subroutine calculate_spec_vol_HI_1d(T, S, pressure, specvol, HI, EOS, US, halo, spv_ref) +subroutine calc_spec_vol_HI_1d(T, S, pressure, specvol, HI, EOS, US, halo, spv_ref) type(hor_index_type), intent(in) :: HI !< The horizontal index structure real, dimension(HI%isd:HI%ied), intent(in) :: T !< Potential temperature referenced to the surface [degC] real, dimension(HI%isd:HI%ied), intent(in) :: S !< Salinity [ppt] @@ -466,12 +440,11 @@ subroutine calculate_spec_vol_HI_1d(T, S, pressure, specvol, HI, EOS, US, halo, ! Local variables real, dimension(HI%isd:HI%ied) :: pres ! Pressure converted to [Pa] - real, dimension(HI%isd:HI%ied) :: rho ! Density [kg m-3] real :: spv_reference ! spv_ref converted to [m3 kg-1] integer :: i, is, ie, start, npts, halo_sz if (.not.associated(EOS)) call MOM_error(FATAL, & - "calculate_spec_vol_HI_1d called with an unassociated EOS_type EOS.") + "calc_spec_vol_HI_1d called with an unassociated EOS_type EOS.") halo_sz = 0 ; if (present(halo)) halo_sz = halo @@ -480,71 +453,22 @@ subroutine calculate_spec_vol_HI_1d(T, S, pressure, specvol, HI, EOS, US, halo, is = HI%isc - halo_sz ; ie = HI%iec + halo_sz if ((US%RL2_T2_to_Pa == 1.0) .and. (US%R_to_kg_m3 == 1.0)) then - 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_HI_1d: EOS%form_of_EOS is not valid.") - end select + call calculate_spec_vol_array(T, S, pressure, specvol, start, npts, EOS, spv_ref) elseif (present(spv_ref)) then ! This is the same as above, but with some extra work to rescale variables. do i=is,ie ; pres(i) = US%RL2_T2_to_Pa * pressure(i) ; enddo spv_reference = US%kg_m3_to_R*spv_ref - select case (EOS%form_of_EOS) - case (EOS_LINEAR) - call calculate_spec_vol_linear(T, S, pres, specvol, start, npts, & - EOS%rho_T0_S0, EOS%drho_dT, EOS%drho_dS, spv_reference) - case (EOS_UNESCO) - call calculate_spec_vol_unesco(T, S, pres, specvol, start, npts, spv_reference) - case (EOS_WRIGHT) - call calculate_spec_vol_wright(T, S, pres, specvol, start, npts, spv_reference) - case (EOS_TEOS10) - call calculate_spec_vol_teos10(T, S, pres, specvol, start, npts, spv_reference) - case (EOS_NEMO) - call calculate_density_nemo(T, S, pres, rho, start, npts) - specvol = 1.0 / rho - spv_reference - case default - call MOM_error(FATAL, "calculate_spec_vol_HI_1d: EOS%form_of_EOS is not valid.") - end select + call calculate_spec_vol_array(T, S, pres, specvol, start, npts, EOS, spv_reference) else ! There is rescaling of variables, but spv_ref is not present. Passing a 0 value of spv_ref ! changes answers at roundoff for some equations of state, like Wright and UNESCO. do i=is,ie ; pres(i) = US%RL2_T2_to_Pa * pressure(i) ; enddo - select case (EOS%form_of_EOS) - case (EOS_LINEAR) - call calculate_spec_vol_linear(T, S, pres, specvol, start, npts, & - EOS%rho_T0_S0, EOS%drho_dT, EOS%drho_dS) - case (EOS_UNESCO) - call calculate_spec_vol_unesco(T, S, pres, specvol, start, npts) - case (EOS_WRIGHT) - call calculate_spec_vol_wright(T, S, pres, specvol, start, npts) - case (EOS_TEOS10) - call calculate_spec_vol_teos10(T, S, pres, specvol, start, npts) - case (EOS_NEMO) - call calculate_density_nemo(T, S, pres, rho, start, npts) - do i=is,ie ; specvol(i) = 1.0 / rho(i) ; enddo - case default - call MOM_error(FATAL, "calculate_spec_vol_HI_1d: EOS%form_of_EOS is not valid.") - end select + call calculate_spec_vol_array(T, S, pres, specvol, start, npts, EOS) endif if (US%R_to_kg_m3 /= 1.0) then ; do i=is,ie specvol(i) = US%R_to_kg_m3 * specvol(i) enddo ; endif -end subroutine calculate_spec_vol_HI_1d +end subroutine calc_spec_vol_HI_1d !> Calls the appropriate subroutine to calculate the freezing point for scalar inputs. subroutine calculate_TFreeze_scalar(S, pressure, T_fr, EOS, pres_scale) @@ -727,38 +651,10 @@ subroutine calculate_density_derivs_HI_1d(T, S, pressure, drho_dT, drho_dS, HI, is = HI%isc - halo_sz ; ie = HI%iec + halo_sz if (US%RL2_T2_to_Pa == 1.0) then - 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) - case (EOS_UNESCO) - call calculate_density_derivs_unesco(T, S, pressure, drho_dT, drho_dS, start, npts) - case (EOS_WRIGHT) - call calculate_density_derivs_wright(T, S, pressure, drho_dT, drho_dS, start, npts) - case (EOS_TEOS10) - call calculate_density_derivs_teos10(T, S, pressure, drho_dT, drho_dS, start, npts) - case (EOS_NEMO) - call calculate_density_derivs_nemo(T, S, pressure, drho_dT, drho_dS, start, npts) - case default - call MOM_error(FATAL, "calculate_density_derivs_HI_1d: EOS%form_of_EOS is not valid.") - end select + call calculate_density_derivs_array(T, S, pressure, drho_dT, drho_dS, start, npts, EOS) else do i=is,ie ; pres(i) = US%RL2_T2_to_Pa * pressure(i) ; enddo - select case (EOS%form_of_EOS) - case (EOS_LINEAR) - call calculate_density_derivs_linear(T, S, pres, 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, pres, drho_dT, drho_dS, start, npts) - case (EOS_WRIGHT) - call calculate_density_derivs_wright(T, S, pres, drho_dT, drho_dS, start, npts) - case (EOS_TEOS10) - call calculate_density_derivs_teos10(T, S, pres, drho_dT, drho_dS, start, npts) - case (EOS_NEMO) - call calculate_density_derivs_nemo(T, S, pres, drho_dT, drho_dS, start, npts) - case default - call MOM_error(FATAL, "calculate_density_derivs_HI_1d: EOS%form_of_EOS is not valid.") - end select + call calculate_density_derivs_array(T, S, pres, drho_dT, drho_dS, start, npts, EOS) endif if (US%kg_m3_to_R /= 1.0) then ; do i=is,ie @@ -964,101 +860,101 @@ subroutine calculate_density_second_derivs_scalar(T, S, pressure, drho_dS_dS, dr end subroutine calculate_density_second_derivs_scalar !> Calls the appropriate subroutine to calculate specific volume derivatives for an array. -subroutine calculate_spec_vol_derivs_array(T, S, pressure, dSV_dT, dSV_dS, start, npts, EOS, US, scale) +subroutine calculate_spec_vol_derivs_array(T, S, pressure, dSV_dT, dSV_dS, start, npts, EOS) real, dimension(:), intent(in) :: T !< Potential temperature referenced to the surface [degC] real, dimension(:), intent(in) :: S !< Salinity [ppt] - real, dimension(:), intent(in) :: pressure !< Pressure [Pa] or [R L2 T-2 ~> Pa] + real, dimension(:), intent(in) :: pressure !< Pressure [Pa] real, dimension(:), intent(inout) :: dSV_dT !< The partial derivative of specific volume with potential - !! temperature [m3 kg-1 degC-1] or [R-1 degC-1 ~> m3 kg-1 degC-1] + !! temperature [m3 kg-1 degC-1] real, dimension(:), intent(inout) :: dSV_dS !< The partial derivative of specific volume with salinity - !! [m3 kg-1 ppt-1] or [R-1 ppt-1 ~> m3 kg-1 ppt-1] + !! [m3 kg-1 ppt-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 - type(unit_scale_type), optional, intent(in) :: US !< A dimensional unit scaling type - real, optional, intent(in) :: scale !< A multiplicative factor by which to scale specific - !! volume in combination with scaling given by US [various] ! Local variables real, dimension(size(T)) :: press ! Pressure converted to [Pa] real, dimension(size(T)) :: rho ! In situ density [kg m-3] real, dimension(size(T)) :: dRho_dT ! Derivative of density with temperature [kg m-3 degC-1] real, dimension(size(T)) :: dRho_dS ! Derivative of density with salinity [kg m-3 ppt-1] - real :: p_scale ! A factor to convert pressure to units of Pa [Pa T2 R-1 L-2 ~> 1] - real :: spv_scale ! A factor to convert specific volume from m3 kg-1 to the desired units [kg R-1 m-3 ~> 1] integer :: j if (.not.associated(EOS)) call MOM_error(FATAL, & "calculate_spec_vol_derivs_array called with an unassociated EOS_type EOS.") - p_scale = 1.0 ; if (present(US)) p_scale = US%RL2_T2_to_Pa + select case (EOS%form_of_EOS) + case (EOS_LINEAR) + call calculate_specvol_derivs_linear(T, S, pressure, dSV_dT, dSV_dS, start, & + npts, EOS%Rho_T0_S0, EOS%dRho_dT, EOS%dRho_dS) + case (EOS_UNESCO) + call calculate_density_unesco(T, S, pressure, rho, start, npts) + call calculate_density_derivs_unesco(T, S, pressure, drho_dT, drho_dS, start, npts) + do j=start,start+npts-1 + dSV_dT(j) = -dRho_DT(j)/(rho(j)**2) + dSV_dS(j) = -dRho_DS(j)/(rho(j)**2) + enddo + case (EOS_WRIGHT) + call calculate_specvol_derivs_wright(T, S, pressure, dSV_dT, dSV_dS, start, npts) + case (EOS_TEOS10) + call calculate_specvol_derivs_teos10(T, S, pressure, dSV_dT, dSV_dS, start, npts) + case (EOS_NEMO) + call calculate_density_nemo(T, S, pressure, rho, start, npts) + call calculate_density_derivs_nemo(T, S, pressure, drho_dT, drho_dS, start, npts) + do j=start,start+npts-1 + dSV_dT(j) = -dRho_DT(j)/(rho(j)**2) + dSV_dS(j) = -dRho_DS(j)/(rho(j)**2) + enddo + case default + call MOM_error(FATAL, "calculate_spec_vol_derivs_array: EOS%form_of_EOS is not valid.") + end select - if (p_scale == 1.0) then - select case (EOS%form_of_EOS) - case (EOS_LINEAR) - call calculate_specvol_derivs_linear(T, S, pressure, dSV_dT, dSV_dS, start, & - npts, EOS%Rho_T0_S0, EOS%dRho_dT, EOS%dRho_dS) - case (EOS_UNESCO) - call calculate_density_unesco(T, S, pressure, rho, start, npts) - call calculate_density_derivs_unesco(T, S, pressure, drho_dT, drho_dS, start, npts) - do j=start,start+npts-1 - dSV_dT(j) = -dRho_DT(j)/(rho(j)**2) - dSV_dS(j) = -dRho_DS(j)/(rho(j)**2) - enddo - case (EOS_WRIGHT) - call calculate_specvol_derivs_wright(T, S, pressure, dSV_dT, dSV_dS, start, npts) - case (EOS_TEOS10) - call calculate_specvol_derivs_teos10(T, S, pressure, dSV_dT, dSV_dS, start, npts) - case (EOS_NEMO) - call calculate_density_nemo(T, S, pressure, rho, start, npts) - call calculate_density_derivs_nemo(T, S, pressure, drho_dT, drho_dS, start, npts) - do j=start,start+npts-1 - dSV_dT(j) = -dRho_DT(j)/(rho(j)**2) - dSV_dS(j) = -dRho_DS(j)/(rho(j)**2) - enddo - case default - call MOM_error(FATAL, "calculate_spec_vol_derivs_array: EOS%form_of_EOS is not valid.") - end select +end subroutine calculate_spec_vol_derivs_array + + +!> Calls the appropriate subroutine to calculate specific volume derivatives for an array with unit scaling. +subroutine calc_spec_vol_derivs_US(T, S, pressure, dSV_dT, dSV_dS, start, npts, EOS, US, scale) + real, dimension(:), intent(in) :: T !< Potential temperature referenced to the surface [degC] + real, dimension(:), intent(in) :: S !< Salinity [ppt] + real, dimension(:), intent(in) :: pressure !< Pressure [R L2 T-2 ~> Pa] + real, dimension(:), intent(inout) :: dSV_dT !< The partial derivative of specific volume with potential + !! temperature [R-1 degC-1 ~> m3 kg-1 degC-1] + real, dimension(:), intent(inout) :: dSV_dS !< The partial derivative of specific volume with salinity + !! [R-1 ppt-1 ~> m3 kg-1 ppt-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 + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, optional, intent(in) :: scale !< A multiplicative factor by which to scale specific + !! volume in combination with scaling given by US [various] + + ! Local variables + real, dimension(size(T)) :: press ! Pressure converted to [Pa] + real :: spv_scale ! A factor to convert specific volume from m3 kg-1 to the desired units [kg R-1 m-3 ~> 1] + integer :: i, is, ie + + if (.not.associated(EOS)) call MOM_error(FATAL, & + "calculate_spec_vol_derivs_array called with an unassociated EOS_type EOS.") + + is = start ; ie = is + npts - 1 + + if (US%RL2_T2_to_Pa == 1.0) then + call calculate_spec_vol_derivs_array(T, S, pressure, dSV_dT, dSV_dS, start, npts, EOS) else - do j=start,start+npts-1 ; press(j) = p_scale * pressure(j) ; enddo - select case (EOS%form_of_EOS) - case (EOS_LINEAR) - call calculate_specvol_derivs_linear(T, S, press, dSV_dT, dSV_dS, start, & - npts, EOS%Rho_T0_S0, EOS%dRho_dT, EOS%dRho_dS) - case (EOS_UNESCO) - call calculate_density_unesco(T, S, press, rho, start, npts) - call calculate_density_derivs_unesco(T, S, press, drho_dT, drho_dS, start, npts) - do j=start,start+npts-1 - dSV_dT(j) = -dRho_DT(j)/(rho(j)**2) - dSV_dS(j) = -dRho_DS(j)/(rho(j)**2) - enddo - case (EOS_WRIGHT) - call calculate_specvol_derivs_wright(T, S, press, dSV_dT, dSV_dS, start, npts) - case (EOS_TEOS10) - call calculate_specvol_derivs_teos10(T, S, press, dSV_dT, dSV_dS, start, npts) - case (EOS_NEMO) - call calculate_density_nemo(T, S, pressure, rho, start, npts) - call calculate_density_derivs_nemo(T, S, press, drho_dT, drho_dS, start, npts) - do j=start,start+npts-1 - dSV_dT(j) = -dRho_DT(j)/(rho(j)**2) - dSV_dS(j) = -dRho_DS(j)/(rho(j)**2) - enddo - case default - call MOM_error(FATAL, "calculate_spec_vol_derivs_array: EOS%form_of_EOS is not valid.") - end select + do i=is,ie ; press(i) = US%RL2_T2_to_Pa * pressure(i) ; enddo + call calculate_spec_vol_derivs_array(T, S, press, dSV_dT, dSV_dS, start, npts, EOS) endif - spv_scale = 1.0 ; if (present(US)) spv_scale = US%R_to_kg_m3 + spv_scale = US%R_to_kg_m3 if (present(scale)) spv_scale = spv_scale * scale - if (spv_scale /= 1.0) then ; do j=start,start+npts-1 - dSV_dT(j) = spv_scale * dSV_dT(j) - dSV_dS(j) = spv_scale * dSV_dS(j) + if (spv_scale /= 1.0) then ; do i=is,ie + dSV_dT(i) = spv_scale * dSV_dT(i) + dSV_dS(i) = spv_scale * dSV_dS(i) enddo ; endif -end subroutine calculate_spec_vol_derivs_array +end subroutine calc_spec_vol_derivs_US !> Calls the appropriate subroutine to calculate specific volume derivatives for an array. -subroutine calculate_spec_vol_derivs_HI_1d(T, S, pressure, dSV_dT, dSV_dS, HI, EOS, US, halo) +subroutine calc_spec_vol_derivs_HI_1d(T, S, pressure, dSV_dT, dSV_dS, HI, EOS, US, halo) type(hor_index_type), intent(in) :: HI !< The horizontal index structure real, dimension(HI%isd:HI%ied), intent(in) :: T !< Potential temperature referenced to the surface [degC] real, dimension(HI%isd:HI%ied), intent(in) :: S !< Salinity [ppt] @@ -1096,7 +992,7 @@ subroutine calculate_spec_vol_derivs_HI_1d(T, S, pressure, dSV_dT, dSV_dS, HI, E dSV_dS(i) = US%R_to_kg_m3 * dSV_dS(i) enddo ; endif -end subroutine calculate_spec_vol_derivs_HI_1d +end subroutine calc_spec_vol_derivs_HI_1d !> Calls the appropriate subroutine to calculate the density and compressibility for 1-D array inputs. From 04fcfd4567cc5307eca96ba8421c29d1c873c18d Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Tue, 14 Apr 2020 09:50:55 -0400 Subject: [PATCH 175/316] +Rescaled args to find_depth_of_pressure_in_cell Rescaled the units of the pressure, density, and gravitational acceleration arguments to find_depth_of_pressure_in_cell, frac_dp_at_pos, trim_for_ice and cut_off_column_top for dimensional consistency testing and code simplification. One change corrected an omitted scaling factor when the optional z_tol argument is omitted, but this does not impact any solutions as this argument is present in all active cases. Also cleaned up some bizarre error messages starting with 'Blurgh!', which is apparently an artificial expletive invented to circumvent censors, but has now been censored and replaced with a more informative message. All answers are bitwise identical, but the units of some arguments have changed and there are new unit_scale_type arguments to some routines. --- src/equation_of_state/MOM_EOS.F90 | 64 +++++++++------ .../MOM_state_initialization.F90 | 77 +++++++++++-------- 2 files changed, 83 insertions(+), 58 deletions(-) diff --git a/src/equation_of_state/MOM_EOS.F90 b/src/equation_of_state/MOM_EOS.F90 index 82f59ca012..c1fd5fd42f 100644 --- a/src/equation_of_state/MOM_EOS.F90 +++ b/src/equation_of_state/MOM_EOS.F90 @@ -1947,29 +1947,34 @@ end subroutine int_density_dz_generic_plm !> Find the depth at which the reconstructed pressure matches P_tgt subroutine find_depth_of_pressure_in_cell(T_t, T_b, S_t, S_b, z_t, z_b, P_t, P_tgt, & - rho_ref, G_e, EOS, P_b, z_out, z_tol) + rho_ref, G_e, EOS, US, P_b, z_out, z_tol) real, intent(in) :: T_t !< Potential temperatue at the cell top [degC] real, intent(in) :: T_b !< Potential temperatue at the cell bottom [degC] real, intent(in) :: S_t !< Salinity at the cell top [ppt] real, intent(in) :: S_b !< Salinity at the cell bottom [ppt] real, intent(in) :: z_t !< Absolute height of top of cell [Z ~> m] (Boussinesq ????) real, intent(in) :: z_b !< Absolute height of bottom of cell [Z ~> m] - real, intent(in) :: P_t !< Anomalous pressure of top of cell, relative to g*rho_ref*z_t [Pa] - real, intent(in) :: P_tgt !< Target pressure at height z_out, relative to g*rho_ref*z_out [Pa] - real, intent(in) :: rho_ref !< Reference density with which calculation are anomalous to - real, intent(in) :: G_e !< Gravitational acceleration [m2 Z-1 s-2 ~> m s-2] + real, intent(in) :: P_t !< Anomalous pressure of top of cell, relative to g*rho_ref*z_t [R L2 T-2 ~> Pa] + real, intent(in) :: P_tgt !< Target pressure at height z_out, relative to g*rho_ref*z_out [R L2 T-2 ~> Pa] + real, intent(in) :: rho_ref !< Reference density with which calculation are anomalous to [R ~> kg m-3] + real, intent(in) :: G_e !< Gravitational acceleration [L2 Z-1 T-2 ~> m s-2] type(EOS_type), pointer :: EOS !< Equation of state structure - real, intent(out) :: P_b !< Pressure at the bottom of the cell [Pa] + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, intent(out) :: P_b !< Pressure at the bottom of the cell [R L2 T-2 ~> Pa] real, intent(out) :: z_out !< Absolute depth at which anomalous pressure = p_tgt [Z ~> m] real, optional, intent(in) :: z_tol !< The tolerance in finding z_out [Z ~> m] + ! Local variables - real :: top_weight, bottom_weight, rho_anom, w_left, w_right, GxRho, dz, dp, F_guess, F_l, F_r - real :: Pa, Pa_left, Pa_right, Pa_tol ! Pressure anomalies, P = integral of g*(rho-rho_ref) dz + real :: dp ! Pressure thickness of the layer [R L2 T-2 ~> Pa] + real :: F_guess, F_l, F_r ! Fractional positions [nondim] + real :: GxRho ! The product of the gravitational acceleration and reference density [R L2 Z-1 T-2 ~> Pa m-1] + real :: Pa, Pa_left, Pa_right, Pa_tol ! Pressure anomalies, P = integral of g*(rho-rho_ref) dz [R L2 T-2 ~> Pa] + character(len=240) :: msg GxRho = G_e * rho_ref ! Anomalous pressure difference across whole cell - dp = frac_dp_at_pos(T_t, T_b, S_t, S_b, z_t, z_b, rho_ref, G_e, 1.0, EOS) + dp = frac_dp_at_pos(T_t, T_b, S_t, S_b, z_t, z_b, rho_ref, G_e, 1.0, EOS, US) P_b = P_t + dp ! Anomalous pressure at bottom of cell @@ -1987,31 +1992,32 @@ subroutine find_depth_of_pressure_in_cell(T_t, T_b, S_t, S_b, z_t, z_b, P_t, P_t Pa_left = P_t - P_tgt ! Pa_left < 0 F_r = 1. Pa_right = P_b - P_tgt ! Pa_right > 0 - Pa_tol = GxRho * 1.e-5 ! 1e-5 has dimensions of m, but should be converted to the units of z. + Pa_tol = GxRho * 1.0e-5*US%m_to_Z if (present(z_tol)) Pa_tol = GxRho * z_tol - F_guess = F_l - Pa_left / ( Pa_right -Pa_left ) * ( F_r - F_l ) + + F_guess = F_l - Pa_left / (Pa_right - Pa_left) * (F_r - F_l) Pa = Pa_right - Pa_left ! To get into iterative loop do while ( abs(Pa) > Pa_tol ) z_out = z_t + ( z_b - z_t ) * F_guess - Pa = frac_dp_at_pos(T_t, T_b, S_t, S_b, z_t, z_b, rho_ref, G_e, F_guess, EOS) - ( P_tgt - P_t ) + Pa = frac_dp_at_pos(T_t, T_b, S_t, S_b, z_t, z_b, rho_ref, G_e, F_guess, EOS, US) - ( P_tgt - P_t ) if (PaPa_right) then - write(0,*) Pa_left,Pa,Pa_right,P_t-P_tgt,P_b-P_tgt - stop 'Blurgh! Too positive' + write(msg,*) Pa_left,Pa,Pa_right,P_t-P_tgt,P_b-P_tgt + call MOM_error(FATAL, 'find_depth_of_pressure_in_cell out of bounds positive: /n'//msg) elseif (Pa>0.) then Pa_right = Pa F_r = F_guess else ! Pa == 0 return endif - F_guess = F_l - Pa_left / ( Pa_right -Pa_left ) * ( F_r - F_l ) + F_guess = F_l - Pa_left / (Pa_right - Pa_left) * (F_r - F_l) enddo @@ -2019,22 +2025,30 @@ 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 -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 function frac_dp_at_pos(T_t, T_b, S_t, S_b, z_t, z_b, rho_ref, G_e, pos, EOS, US) real, intent(in) :: T_t !< Potential temperatue at the cell top [degC] real, intent(in) :: T_b !< Potential temperatue at the cell bottom [degC] real, intent(in) :: S_t !< Salinity at the cell top [ppt] real, intent(in) :: S_b !< Salinity at the cell bottom [ppt] real, intent(in) :: z_t !< The geometric height at the top of the layer [Z ~> m] real, intent(in) :: z_b !< The geometric height at the bottom of the layer [Z ~> m] - real, intent(in) :: rho_ref !< A mean density [kg m-3], that is subtracted out to + real, intent(in) :: rho_ref !< A mean density [R ~> kg m-3], that is subtracted out to !! reduce the magnitude of each of the integrals. - real, intent(in) :: G_e !< The Earth's gravitational acceleration [m s-2] + real, intent(in) :: G_e !< The Earth's gravitational acceleration [L2 Z-1 T-2 ~> m s-2] real, intent(in) :: pos !< The fractional vertical position, 0 to 1 [nondim] type(EOS_type), pointer :: EOS !< Equation of state structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real :: fract_dp_at_pos !< The change in pressure from the layer top to + !! fractional position pos [R L2 T-2 ~> Pa] ! Local variables - real, parameter :: C1_90 = 1.0/90.0 ! Rational constants. - real :: dz, top_weight, bottom_weight, rho_ave - real, dimension(5) :: T5, S5, p5, rho5 + real, parameter :: C1_90 = 1.0/90.0 ! A rational constant [nondim] + real :: dz ! Distance from the layer top [Z ~> m] + real :: top_weight, bottom_weight ! Fractional weights at quadrature points [nondim] + real :: rho_ave ! Average density [R ~> kg m-3] + real, dimension(5) :: T5 ! Tempratures at quadrature points [degC] + real, dimension(5) :: S5 ! Salinities at quadrature points [ppt] + real, dimension(5) :: p5 ! Pressures at quadrature points [R L2 T-2 ~> Pa] + real, dimension(5) :: rho5 ! Densities at quadrature points [R ~> kg m-3] integer :: n do n=1,5 @@ -2046,10 +2060,10 @@ real function frac_dp_at_pos(T_t, T_b, S_t, S_b, z_t, z_b, rho_ref, G_e, pos, EO T5(n) = top_weight * T_t + bottom_weight * T_b p5(n) = ( top_weight * z_t + bottom_weight * z_b ) * ( G_e * rho_ref ) enddo - call calculate_density_array(T5, S5, p5, rho5, 1, 5, EOS) + call calculate_density_array(T5, S5, p5, rho5, 1, 5, EOS, US=US) rho5(:) = rho5(:) !- rho_ref ! Work with anomalies relative to rho_ref - ! Use Boole's rule to estimate the average density + ! Use Bode's rule to estimate the average density rho_ave = C1_90*(7.0*(rho5(1)+rho5(5)) + 32.0*(rho5(2)+rho5(4)) + 12.0*rho5(3)) dz = ( z_t - z_b ) * pos diff --git a/src/initialization/MOM_state_initialization.F90 b/src/initialization/MOM_state_initialization.F90 index a9ba5eee85..3cdcb5bcfd 100644 --- a/src/initialization/MOM_state_initialization.F90 +++ b/src/initialization/MOM_state_initialization.F90 @@ -1094,12 +1094,12 @@ subroutine trim_for_ice(PF, G, GV, US, ALE_CSp, tv, h, just_read_params) !! only read parameters without changing h. ! 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)) :: p_surf ! Imposed pressure on ocean at surface [R L2 T-2 ~> Pa] 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. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: T_t, T_b ! of salinity [ppt] and temperature [degC] within each layer. character(len=200) :: inputdir, filename, p_surf_file, p_surf_var ! Strings for file/path - real :: scale_factor ! A file-dependent scaling vactor for the input pressurs. - real :: min_thickness ! The minimum layer thickness, recast into Z units. + real :: scale_factor ! A file-dependent scaling factor for the input pressure. + real :: min_thickness ! The minimum layer thickness, recast into Z units [Z ~> m]. integer :: i, j, k logical :: default_2018_answers, remap_answers_2018 logical :: just_read ! If true, just read parameters but set nothing. @@ -1113,7 +1113,7 @@ subroutine trim_for_ice(PF, G, GV, US, ALE_CSp, tv, h, just_read_params) fail_if_missing=.not.just_read, do_not_log=just_read) call get_param(PF, mdl, "SURFACE_PRESSURE_VAR", p_surf_var, & "The initial condition variable for the surface height.", & - units="kg m-2", default="", do_not_log=just_read) + units="kg m-2", default="", do_not_log=just_read) !### The units here should be Pa? call get_param(PF, mdl, "INPUTDIR", inputdir, default=".", do_not_log=.true.) filename = trim(slasher(inputdir))//trim(p_surf_file) if (.not.just_read) call log_param(PF, mdl, "!INPUTDIR/SURFACE_HEIGHT_IC_FILE", filename) @@ -1140,7 +1140,8 @@ subroutine trim_for_ice(PF, G, GV, US, ALE_CSp, tv, h, just_read_params) if (just_read) return ! All run-time parameters have been read, so return. - call MOM_read_data(filename, p_surf_var, p_surf, G%Domain, scale=scale_factor) + call MOM_read_data(filename, p_surf_var, p_surf, G%Domain, & + scale=scale_factor*US%kg_m3_to_R*US%m_s_to_L_T**2) if (use_remapping) then allocate(remap_CS) @@ -1159,7 +1160,7 @@ subroutine trim_for_ice(PF, G, GV, US, ALE_CSp, tv, h, just_read_params) endif do j=G%jsc,G%jec ; do i=G%isc,G%iec - call cut_off_column_top(GV%ke, tv, GV, US, GV%mks_g_Earth*US%Z_to_m, G%bathyT(i,j), & + call cut_off_column_top(GV%ke, tv, GV, US, GV%g_Earth, G%bathyT(i,j), & min_thickness, tv%T(i,j,:), T_t(i,j,:), T_b(i,j,:), & tv%S(i,j,:), S_t(i,j,:), S_b(i,j,:), p_surf(i,j), h(i,j,:), remap_CS, & z_tol=1.0e-5*US%m_to_Z, remap_answers_2018=remap_answers_2018) @@ -1175,8 +1176,8 @@ subroutine cut_off_column_top(nk, tv, GV, US, G_earth, depth, min_thickness, T, integer, intent(in) :: nk !< Number of layers type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamics structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - real, intent(in) :: G_earth !< Gravitational acceleration [m2 Z-1 s-2 ~> m s-2] + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, intent(in) :: G_earth !< Gravitational acceleration [L2 Z-1 T-2 ~> m s-2] real, intent(in) :: depth !< Depth of ocean column [Z ~> m]. real, intent(in) :: min_thickness !< Smallest thickness allowed [Z ~> m]. real, dimension(nk), intent(inout) :: T !< Layer mean temperature [degC] @@ -1185,7 +1186,7 @@ subroutine cut_off_column_top(nk, tv, GV, US, G_earth, depth, min_thickness, T, real, dimension(nk), intent(inout) :: S !< Layer mean salinity [ppt] real, dimension(nk), intent(in) :: S_t !< Salinity at top of layer [ppt] real, dimension(nk), intent(in) :: S_b !< Salinity at bottom of layer [ppt] - real, intent(in) :: p_surf !< Imposed pressure on ocean at surface [Pa] + real, intent(in) :: p_surf !< Imposed pressure on ocean at surface [R L2 T-2 ~> Pa] real, dimension(nk), intent(inout) :: h !< Layer thickness [H ~> m or kg m-2] type(remapping_CS), pointer :: remap_CS !< Remapping structure for remapping T and S, !! if associated @@ -1197,9 +1198,10 @@ subroutine cut_off_column_top(nk, tv, GV, US, G_earth, depth, min_thickness, T, !! forms of the same expressions. ! Local variables - real, dimension(nk+1) :: e ! Top and bottom edge values for reconstructions + real, dimension(nk+1) :: e ! Top and bottom edge values for reconstructions [Z ~> m] real, dimension(nk) :: h0, S0, T0, h1, S1, T1 - real :: P_t, P_b, z_out, e_top + real :: P_t, P_b ! Top and bottom pressures [R L2 T-2 ~> Pa] + real :: z_out, e_top logical :: answers_2018 integer :: k @@ -1216,7 +1218,7 @@ subroutine cut_off_column_top(nk, tv, GV, US, G_earth, depth, min_thickness, T, e_top = e(1) do k=1,nk call find_depth_of_pressure_in_cell(T_t(k), T_b(k), S_t(k), S_b(k), e(K), e(K+1), & - P_t, p_surf, US%R_to_kg_m3*GV%Rho0, G_earth, tv%eqn_of_state, & + P_t, p_surf, GV%Rho0, G_earth, tv%eqn_of_state, US, & P_b, z_out, z_tol=z_tol) if (z_out>=e(K)) then ! Imposed pressure was less that pressure at top of cell @@ -2417,51 +2419,60 @@ subroutine MOM_state_init_tests(G, GV, US, tv) type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamics structure. + ! Local variables integer, parameter :: nk=5 - real, dimension(nk) :: T, T_t, T_b, S, S_t, S_b, rho, h, z - real, dimension(nk+1) :: e + real, dimension(nk) :: T, T_t, T_b ! Temperatures [degC] + real, dimension(nk) :: S, S_t, S_b ! Salinities [ppt] + real, dimension(nk) :: rho ! Layer density [R ~> kg m-3] + real, dimension(nk) :: h ! Layer thicknesses [H ~> m or kg m-2] + real, dimension(nk) :: z ! Height of layer center [Z ~> m] + real, dimension(nk+1) :: e ! Interface heights [Z ~> m] integer :: k - real :: P_tot, P_t, P_b, z_out + real :: P_tot, P_t, P_b ! Pressures [R L2 T-2 ~> Pa] + real :: z_out ! Output height [Z ~> m] + real :: I_z_scale ! The inverse of the height scale for prescribed gradients [Z-1 ~> m-1] type(remapping_CS), pointer :: remap_CS => NULL() + I_z_scale = 1.0 / (500.0*US%m_to_Z) do k = 1, nk - h(k) = 100. + h(k) = 100.0*GV%m_to_H enddo e(1) = 0. do K = 1, nk - e(K+1) = e(K) - h(k) + e(K+1) = e(K) - GV%H_to_Z * h(k) enddo P_tot = 0. do k = 1, nk z(k) = 0.5 * ( e(K) + e(K+1) ) - T_t(k) = 20.+(0./500.)*e(k) - T(k) = 20.+(0./500.)*z(k) - T_b(k) = 20.+(0./500.)*e(k+1) - 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)), -US%R_to_kg_m3*GV%Rho0*GV%mks_g_Earth*z(k), & - rho(k), tv%eqn_of_state) - P_tot = P_tot + GV%mks_g_Earth * rho(k) * h(k) + T_t(k) = 20. + (0. * I_z_scale) * e(k) + T(k) = 20. + (0. * I_z_scale)*z(k) + T_b(k) = 20. + (0. * I_z_scale)*e(k+1) + S_t(k) = 35. - (0. * I_z_scale)*e(k) + S(k) = 35. + (0. * I_z_scale)*z(k) + S_b(k) = 35. - (0. * I_z_scale)*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*US%m_to_Z*z(k), & + rho(k), tv%eqn_of_state, US=US) + P_tot = P_tot + GV%g_Earth * rho(k) * GV%H_to_Z*h(k) enddo P_t = 0. do k = 1, nk call find_depth_of_pressure_in_cell(T_t(k), T_b(k), S_t(k), S_b(k), e(K), e(K+1), P_t, 0.5*P_tot, & - US%R_to_kg_m3*GV%Rho0, GV%mks_g_Earth, tv%eqn_of_state, P_b, z_out) - write(0,*) k,P_t,P_b,0.5*P_tot,e(K),e(K+1),z_out + GV%Rho0, GV%g_Earth, tv%eqn_of_state, US, P_b, z_out) + write(0,*) k, US%RL2_T2_to_Pa*P_t, US%RL2_T2_to_Pa*P_b, 0.5*US%RL2_T2_to_Pa*P_tot, & + US%Z_to_m*e(K), US%Z_to_m*e(K+1), US%Z_to_m*z_out P_t = P_b enddo - write(0,*) P_b,P_tot + write(0,*) US%RL2_T2_to_Pa*P_b, US%RL2_T2_to_Pa*P_tot write(0,*) '' write(0,*) ' ==================================================================== ' write(0,*) '' - write(0,*) h - call cut_off_column_top(nk, tv, GV, US, GV%mks_g_Earth, -e(nk+1), GV%Angstrom_H, & + write(0,*) GV%H_to_m*h + call cut_off_column_top(nk, tv, GV, US, GV%g_Earth, -e(nk+1), GV%Angstrom_Z, & T, T_t, T_b, S, S_t, S_b, 0.5*P_tot, h, remap_CS) - write(0,*) h + write(0,*) GV%H_to_m*h end subroutine MOM_state_init_tests From 2aa10917d947819a958610e611e8ce91858ef797 Mon Sep 17 00:00:00 2001 From: alperaltuntas Date: Tue, 14 Apr 2020 11:01:53 -0600 Subject: [PATCH 176/316] optimize barotropic timestepping openmp --- src/core/MOM_barotropic.F90 | 137 ++++++++++++++++++++++-------------- 1 file changed, 83 insertions(+), 54 deletions(-) diff --git a/src/core/MOM_barotropic.F90 b/src/core/MOM_barotropic.F90 index d3dabd2147..fbaadc869f 100644 --- a/src/core/MOM_barotropic.F90 +++ b/src/core/MOM_barotropic.F90 @@ -1584,13 +1584,14 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, call find_face_areas(Datu, Datv, G, GV, US, CS, MS, eta, 1+iev-ie) endif - !$OMP parallel default(shared) + !$OMP parallel default(shared) private(vel_prev, ioff, joff) if (CS%dynamic_psurf .or. .not.project_velocity) then if (use_BT_cont) then !$OMP do do j=jsv-1,jev+1 ; do I=isv-2,iev+1 uhbt(I,j) = find_uhbt(ubt(I,j), BTCL_u(I,j), US) + uhbt0(I,j) enddo ; enddo + !$OMP end do nowait !$OMP do do J=jsv-2,jev+1 ; do i=isv-1,iev+1 vhbt(i,J) = find_vhbt(vbt(i,J), BTCL_v(i,J), US) + vhbt0(i,J) @@ -1627,6 +1628,7 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, do j=js,je ; do i=is,ie eta_sum(i,j) = eta_sum(i,j) + wt_accel2(n) * eta_PF_BT(i,j) enddo ; enddo + !$OMP end do nowait endif if (interp_eta_PF) then @@ -1647,7 +1649,6 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, vbt_old(i,J) = vbt(i,J) enddo ; enddo endif - !$OMP end parallel if (apply_OBCs) then if (MOD(n+G%first_direction,2)==1) then @@ -1657,7 +1658,7 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, endif if (CS%BT_OBC%apply_u_OBCs) then ! save the old value of ubt and uhbt - !$OMP parallel do default(shared) + !$OMP do do J=jsv-joff,jev+joff ; do i=isv-1,iev ubt_prev(i,J) = ubt(i,J) ; uhbt_prev(i,J) = uhbt(i,J) ubt_sum_prev(i,J) = ubt_sum(i,J) ; uhbt_sum_prev(i,J) = uhbt_sum(i,J) ; ubt_wtd_prev(i,J) = ubt_wtd(i,J) @@ -1665,7 +1666,7 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, endif if (CS%BT_OBC%apply_v_OBCs) then ! save the old value of vbt and vhbt - !$OMP parallel do default(shared) + !$OMP do do J=jsv-1,jev ; do i=isv-ioff,iev+ioff vbt_prev(i,J) = vbt(i,J) ; vhbt_prev(i,J) = vhbt(i,J) vbt_sum_prev(i,J) = vbt_sum(i,J) ; vhbt_sum_prev(i,J) = vhbt_sum(i,J) ; vbt_wtd_prev(i,J) = vbt_wtd(i,J) @@ -1673,10 +1674,9 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, endif endif - !$OMP parallel default(shared) private(vel_prev) if (MOD(n+G%first_direction,2)==1) then ! On odd-steps, update v first. - !$OMP do + !$OMP do schedule(static) do J=jsv-1,jev ; do i=isv-1,iev+1 Cor_v(i,J) = -1.0*((amer(I-1,j) * ubt(I-1,j) + cmer(I,j+1) * ubt(I,j+1)) + & (bmer(I,j) * ubt(I,j) + dmer(I-1,j+1) * ubt(I-1,j+1))) - Cor_ref_v(i,J) @@ -1684,20 +1684,23 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, (eta_PF_BT(i,j+1)-eta_PF(i,j+1))*gtot_S(i,j+1)) * & dgeo_de * CS%IdyCv(i,J) enddo ; enddo + !$OMP end do nowait if (CS%dynamic_psurf) then - !$OMP do + !$OMP do schedule(static) do J=jsv-1,jev ; do i=isv-1,iev+1 PFv(i,J) = PFv(i,J) + (p_surf_dyn(i,j) - p_surf_dyn(i,j+1)) * CS%IdyCv(i,J) enddo ; enddo + !$OMP end do nowait endif if (CS%BT_OBC%apply_v_OBCs) then ! zero out PF across boundary - !$OMP do + !$OMP do schedule(static) do J=jsv-1,jev ; do i=isv-1,iev+1 ; if (OBC%segnum_v(i,J) /= OBC_NONE) then PFv(i,J) = 0.0 endif ; enddo ; enddo + !$OMP end do nowait endif - !$OMP do + !$OMP do schedule(static) do J=jsv-1,jev ; do i=isv-1,iev+1 vel_prev = vbt(i,J) vbt(i,J) = bt_rem_v(i,J) * (vbt(i,J) + & @@ -1713,24 +1716,26 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, enddo ; enddo if (use_BT_cont) then - !$OMP do + !$OMP do schedule(static) do J=jsv-1,jev ; do i=isv-1,iev+1 vhbt(i,J) = find_vhbt(vbt_trans(i,J), BTCL_v(i,J), US) + vhbt0(i,J) enddo ; enddo + !$OMP end do nowait else - !$OMP do + !$OMP do schedule(static) do J=jsv-1,jev ; do i=isv-1,iev+1 vhbt(i,J) = Datv(i,J)*vbt_trans(i,J) + vhbt0(i,J) enddo ; enddo + !$OMP end do nowait endif if (CS%BT_OBC%apply_v_OBCs) then ! copy back the value for v-points on the boundary. - !$OMP do + !$OMP do schedule(static) do J=jsv-1,jev ; do i=isv-1,iev+1 ; if (OBC%segnum_v(i,J) /= OBC_NONE) then vbt(i,J) = vbt_prev(i,J) ; vhbt(i,J) = vhbt_prev(i,J) endif ; enddo ; enddo endif ! Now update the zonal velocity. - !$OMP do + !$OMP do schedule(static) do j=jsv,jev ; do I=isv-1,iev Cor_u(I,j) = ((azon(I,j) * vbt(i+1,J) + czon(I,j) * vbt(i,J-1)) + & (bzon(I,j) * vbt(i,J) + dzon(I,j) * vbt(i+1,J-1))) - & @@ -1739,21 +1744,24 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, (eta_PF_BT(i+1,j)-eta_PF(i+1,j))*gtot_W(i+1,j)) * & dgeo_de * CS%IdxCu(I,j) enddo ; enddo + !$OMP end do nowait if (CS%dynamic_psurf) then - !$OMP do + !$OMP do schedule(static) do j=jsv,jev ; do I=isv-1,iev PFu(I,j) = PFu(I,j) + (p_surf_dyn(i,j) - p_surf_dyn(i+1,j)) * CS%IdxCu(I,j) enddo ; enddo + !$OMP end do nowait endif if (CS%BT_OBC%apply_u_OBCs) then ! zero out pressure force across boundary - !$OMP do + !$OMP do schedule(static) do j=jsv,jev ; do I=isv-1,iev ; if (OBC%segnum_u(I,j) /= OBC_NONE) then PFu(I,j) = 0.0 endif ; enddo ; enddo + !$OMP end do nowait endif - !$OMP do + !$OMP do schedule(static) do j=jsv,jev ; do I=isv-1,iev vel_prev = ubt(I,j) ubt(I,j) = bt_rem_u(I,j) * (ubt(I,j) + & @@ -1768,27 +1776,28 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, u_accel_bt(I,j) = u_accel_bt(I,j) + wt_accel(n) * (Cor_u(I,j) + PFu(I,j)) endif enddo ; enddo + !$OMP end do nowait if (use_BT_cont) then - !$OMP do + !$OMP do schedule(static) do j=jsv,jev ; do I=isv-1,iev uhbt(I,j) = find_uhbt(ubt_trans(I,j), BTCL_u(I,j), US) + uhbt0(I,j) enddo ; enddo else - !$OMP do + !$OMP do schedule(static) do j=jsv,jev ; do I=isv-1,iev uhbt(I,j) = Datu(I,j)*ubt_trans(I,j) + uhbt0(I,j) enddo ; enddo endif if (CS%BT_OBC%apply_u_OBCs) then ! copy back the value for u-points on the boundary. - !$OMP do + !$OMP do schedule(static) do j=jsv,jev ; do I=isv-1,iev ; if (OBC%segnum_u(I,j) /= OBC_NONE) then ubt(I,j) = ubt_prev(I,j); uhbt(I,j) = uhbt_prev(I,j) endif ; enddo ; enddo endif else ! On even steps, update u first. - !$OMP do + !$OMP do schedule(static) do j=jsv-1,jev+1 ; do I=isv-1,iev Cor_u(I,j) = ((azon(I,j) * vbt(i+1,J) + czon(I,j) * vbt(i,J-1)) + & (bzon(I,j) * vbt(i,J) + dzon(I,j) * vbt(i+1,J-1))) - & @@ -1797,22 +1806,24 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, (eta_PF_BT(i+1,j)-eta_PF(i+1,j))*gtot_W(i+1,j)) * & dgeo_de * CS%IdxCu(I,j) enddo ; enddo + !$OMP end do nowait if (CS%dynamic_psurf) then - !$OMP do + !$OMP do schedule(static) do j=jsv-1,jev+1 ; do I=isv-1,iev PFu(I,j) = PFu(I,j) + (p_surf_dyn(i,j) - p_surf_dyn(i+1,j)) * CS%IdxCu(I,j) enddo ; enddo + !$OMP end do nowait endif if (CS%BT_OBC%apply_u_OBCs) then ! zero out pressure force across boundary - !$OMP do + !$OMP do schedule(static) do j=jsv,jev ; do I=isv-1,iev ; if (OBC%segnum_u(I,j) /= OBC_NONE) then PFu(I,j) = 0.0 endif ; enddo ; enddo endif - !$OMP do + !$OMP do schedule(static) do j=jsv-1,jev+1 ; do I=isv-1,iev vel_prev = ubt(I,j) ubt(I,j) = bt_rem_u(I,j) * (ubt(I,j) + & @@ -1829,18 +1840,20 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, enddo ; enddo if (use_BT_cont) then - !$OMP do + !$OMP do schedule(static) do j=jsv-1,jev+1 ; do I=isv-1,iev uhbt(I,j) = find_uhbt(ubt_trans(I,j), BTCL_u(I,j), US) + uhbt0(I,j) enddo ; enddo + !$OMP end do nowait else - !$OMP do + !$OMP do schedule(static) do j=jsv-1,jev+1 ; do I=isv-1,iev uhbt(I,j) = Datu(I,j)*ubt_trans(I,j) + uhbt0(I,j) enddo ; enddo + !$OMP end do nowait endif if (CS%BT_OBC%apply_u_OBCs) then ! copy back the value for u-points on the boundary. - !$OMP do + !$OMP do schedule(static) do j=jsv-1,jev+1 ; do I=isv-1,iev ; if (OBC%segnum_u(I,j) /= OBC_NONE) then ubt(I,j) = ubt_prev(I,j); uhbt(I,j) = uhbt_prev(I,j) endif ; enddo ; enddo @@ -1848,7 +1861,7 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, ! Now update the meridional velocity. if (CS%use_old_coriolis_bracket_bug) then - !$OMP do + !$OMP do schedule(static) do J=jsv-1,jev ; do i=isv,iev Cor_v(i,J) = -1.0*((amer(I-1,j) * ubt(I-1,j) + bmer(I,j) * ubt(I,j)) + & (cmer(I,j+1) * ubt(I,j+1) + dmer(I-1,j+1) * ubt(I-1,j+1))) - Cor_ref_v(i,J) @@ -1856,8 +1869,9 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, (eta_PF_BT(i,j+1)-eta_PF(i,j+1))*gtot_S(i,j+1)) * & dgeo_de * CS%IdyCv(i,J) enddo ; enddo + !$OMP end do nowait else - !$OMP do + !$OMP do schedule(static) do J=jsv-1,jev ; do i=isv,iev Cor_v(i,J) = -1.0*((amer(I-1,j) * ubt(I-1,j) + cmer(I,j+1) * ubt(I,j+1)) + & (bmer(I,j) * ubt(I,j) + dmer(I-1,j+1) * ubt(I-1,j+1))) - Cor_ref_v(i,J) @@ -1865,23 +1879,25 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, (eta_PF_BT(i,j+1)-eta_PF(i,j+1))*gtot_S(i,j+1)) * & dgeo_de * CS%IdyCv(i,J) enddo ; enddo + !$OMP end do nowait endif if (CS%dynamic_psurf) then - !$OMP do + !$OMP do schedule(static) do J=jsv-1,jev ; do i=isv,iev PFv(i,J) = PFv(i,J) + (p_surf_dyn(i,j) - p_surf_dyn(i,j+1)) * CS%IdyCv(i,J) enddo ; enddo + !$OMP end do nowait endif if (CS%BT_OBC%apply_v_OBCs) then ! zero out PF across boundary - !$OMP do + !$OMP do schedule(static) do J=jsv-1,jev ; do i=isv-1,iev+1 ; if (OBC%segnum_v(i,J) /= OBC_NONE) then PFv(i,J) = 0.0 endif ; enddo ; enddo endif - !$OMP do + !$OMP do schedule(static) do J=jsv-1,jev ; do i=isv,iev vel_prev = vbt(i,J) vbt(i,J) = bt_rem_v(i,J) * (vbt(i,J) + & @@ -1896,46 +1912,49 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, v_accel_bt(I,j) = v_accel_bt(I,j) + wt_accel(n) * (Cor_v(i,J) + PFv(i,J)) endif enddo ; enddo + !$OMP end do nowait if (use_BT_cont) then - !$OMP do + !$OMP do schedule(static) do J=jsv-1,jev ; do i=isv,iev vhbt(i,J) = find_vhbt(vbt_trans(i,J), BTCL_v(i,J), US) + vhbt0(i,J) enddo ; enddo else - !$OMP do + !$OMP do schedule(static) do J=jsv-1,jev ; do i=isv,iev vhbt(i,J) = Datv(i,J)*vbt_trans(i,J) + vhbt0(i,J) enddo ; enddo endif if (CS%BT_OBC%apply_v_OBCs) then ! copy back the value for v-points on the boundary. - !$OMP do + !$OMP do schedule(static) do J=jsv-1,jev ; do i=isv,iev ; if (OBC%segnum_v(i,J) /= OBC_NONE) then vbt(i,J) = vbt_prev(i,J); vhbt(i,J) = vhbt_prev(i,J) endif ; enddo ; enddo endif endif - !$OMP end parallel - !$OMP parallel default(shared) if (find_PF) then !$OMP do do j=js,je ; do I=is-1,ie PFu_bt_sum(I,j) = PFu_bt_sum(I,j) + wt_accel2(n) * PFu(I,j) enddo ; enddo + !$OMP end do nowait !$OMP do do J=js-1,je ; do i=is,ie PFv_bt_sum(i,J) = PFv_bt_sum(i,J) + wt_accel2(n) * PFv(i,J) enddo ; enddo + !$OMP end do nowait endif if (find_Cor) then !$OMP do do j=js,je ; do I=is-1,ie Coru_bt_sum(I,j) = Coru_bt_sum(I,j) + wt_accel2(n) * Cor_u(I,j) enddo ; enddo + !$OMP end do nowait !$OMP do do J=js-1,je ; do i=is,ie Corv_bt_sum(i,J) = Corv_bt_sum(i,J) + wt_accel2(n) * Cor_v(i,J) enddo ; enddo + !$OMP end do nowait endif !$OMP do @@ -1944,17 +1963,18 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, uhbt_sum(I,j) = uhbt_sum(I,j) + wt_trans(n) * uhbt(I,j) ubt_wtd(I,j) = ubt_wtd(I,j) + wt_vel(n) * ubt(I,j) enddo ; enddo + !$OMP end do nowait !$OMP do do J=js-1,je ; do i=is,ie vbt_sum(i,J) = vbt_sum(i,J) + wt_trans(n) * vbt_trans(i,J) vhbt_sum(i,J) = vhbt_sum(i,J) + wt_trans(n) * vhbt(i,J) vbt_wtd(i,J) = vbt_wtd(i,J) + wt_vel(n) * vbt(i,J) enddo ; enddo - !$OMP end parallel + !$OMP end do nowait if (apply_OBCs) then if (CS%BT_OBC%apply_u_OBCs) then ! copy back the value for u-points on the boundary. - !$OMP parallel do default(shared) + !$OMP do do j=js,je ; do I=is-1,ie if (OBC%segnum_u(I,j) /= OBC_NONE) then ubt_sum(I,j) = ubt_sum_prev(I,j) ; uhbt_sum(I,j) = uhbt_sum_prev(I,j) @@ -1964,7 +1984,7 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, endif if (CS%BT_OBC%apply_v_OBCs) then ! copy back the value for v-points on the boundary. - !$OMP parallel do default(shared) + !$OMP do do J=js-1,je ; do I=is,ie if (OBC%segnum_v(i,J) /= OBC_NONE) then vbt_sum(i,J) = vbt_sum_prev(i,J) ; vhbt_sum(i,J) = vhbt_sum_prev(i,J) @@ -1973,24 +1993,32 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, enddo ; enddo endif + !$OMP single call apply_velocity_OBCs(OBC, ubt, vbt, uhbt, vhbt, & ubt_trans, vbt_trans, eta, ubt_old, vbt_old, CS%BT_OBC, & G, MS, US, iev-ie, dtbt, bebt, use_BT_cont, Datu, Datv, BTCL_u, BTCL_v, & uhbt0, vhbt0) - if (CS%BT_OBC%apply_u_OBCs) then ; do j=js,je ; do I=is-1,ie - if (OBC%segnum_u(I,j) /= OBC_NONE) then - ubt_sum(I,j) = ubt_sum(I,j) + wt_trans(n) * ubt_trans(I,j) - uhbt_sum(I,j) = uhbt_sum(I,j) + wt_trans(n) * uhbt(I,j) - ubt_wtd(I,j) = ubt_wtd(I,j) + wt_vel(n) * ubt(I,j) - endif - enddo ; enddo ; endif - if (CS%BT_OBC%apply_v_OBCs) then ; do J=js-1,je ; do i=is,ie - if (OBC%segnum_v(i,J) /= OBC_NONE) then - vbt_sum(i,J) = vbt_sum(i,J) + wt_trans(n) * vbt_trans(i,J) - vhbt_sum(i,J) = vhbt_sum(i,J) + wt_trans(n) * vhbt(i,J) - vbt_wtd(i,J) = vbt_wtd(i,J) + wt_vel(n) * vbt(i,J) - endif - enddo ; enddo ; endif + !$OMP end single + if (CS%BT_OBC%apply_u_OBCs) then + !$OMP do + do j=js,je ; do I=is-1,ie + if (OBC%segnum_u(I,j) /= OBC_NONE) then + ubt_sum(I,j) = ubt_sum(I,j) + wt_trans(n) * ubt_trans(I,j) + uhbt_sum(I,j) = uhbt_sum(I,j) + wt_trans(n) * uhbt(I,j) + ubt_wtd(I,j) = ubt_wtd(I,j) + wt_vel(n) * ubt(I,j) + endif + enddo ; enddo + endif + if (CS%BT_OBC%apply_v_OBCs) then + !$OMP do + do J=js-1,je ; do i=is,ie + if (OBC%segnum_v(i,J) /= OBC_NONE) then + vbt_sum(i,J) = vbt_sum(i,J) + wt_trans(n) * vbt_trans(i,J) + vhbt_sum(i,J) = vhbt_sum(i,J) + wt_trans(n) * vhbt(i,J) + vbt_wtd(i,J) = vbt_wtd(i,J) + wt_vel(n) * vbt(i,J) + endif + enddo ; enddo + endif endif if (CS%debug_bt) then @@ -1998,13 +2026,14 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, scale=US%s_to_T*US%L_to_m**2*GV%H_to_m) endif - !$OMP parallel do default(shared) + !$OMP do do j=jsv,jev ; do i=isv,iev eta(i,j) = (eta(i,j) + eta_src(i,j)) + (dtbt * CS%IareaT(i,j)) * & ((uhbt(I-1,j) - uhbt(I,j)) + (vhbt(i,J-1) - vhbt(i,J))) eta_wtd(i,j) = eta_wtd(i,j) + eta(i,j) * wt_eta(n) ! Should there be a concern if eta drops below 0 or G%bathyT? enddo ; enddo + !$OMP end parallel if (do_hifreq_output) then time_step_end = time_bt_start + real_to_time(n*US%T_to_s*dtbt) From 22215cb0b778158cf6c56b309980900e0d9a2dca Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Tue, 14 Apr 2020 15:28:00 -0400 Subject: [PATCH 177/316] Internal field index rotation This patch introduces an index rotation feature applied to all internal fields. When this feature is enabled, model fields are initialized on the index map as specified by the configuration or input files. The values of these arrays are then moved to a rotated index map and saved to a new rotated array, which are then used for model simulation. The primary purpose of this feature is to detect regressions in rotationally symmetric calculations, such as fluid dynamic dynamic processes and other transport phenomena. Fields created or read by the drivers are unrotated and are handled as external user-defined field. External fields are rotated or unrotated as they pass between the driver and the ocean model. In order to maintain bit reproducibility, all field initialization is computed or assigned on the input grid. This patch also includes an extension of the test suite, which applies a single quarter-turn to each of the existing tests. The features of this patch are summarized below. Two new configuration features are added: - ROTATE_INDEX: Boolean flag which enables this feature. - INDEX_TURNS: Integer which descibes the number of counterclockwise quarter-turns. Default value is 1. Two new modules and several new functions are added: - MOM_array_transform: Fundamental operations for rotating arrays, vectors, rotationally equivalent pairs - MOM_transform_FMS: Wrappers to FMS operations which can only operate on the unrotated index pax. - Numerous rotation functions have been introduced in various modules associated with initialization (forcing, OBC, etc), which are documented in the source code. The following new features have been added to existing components: - paired checksums (`uvchksum`, `hchksum_pair`) now include a `scalar_pair` argument to distinguish between rotationally equivalent scalars (e.g. grid areas on u- and v-points) and vector components. - `register_restart_pair` was introduced to register rotationally associated pairs. - `turns` has been added to the horizontal index (HI) type, as a means to track the number of quarter turns in lower level operations. - `allocate_forcing_type` and `allocate_mech_forcing` have been extended to permit allocation based on an exisiting (unrotated) reference, alongside the older interface using control flags for each field type. - copy_MOM_domain includes a `turns` argument, to support rotational changes to the FMS domain. Reproducibility: - All results should be bitwise reproducible. A nonphysical exception exception is the calculation of CFL conditions in systems with zero velocity, such as the unit test case. The previous implementation could produce a "negative zero" CFL, whose sign would depend on the number of rotations. The new implementation eliminates these negative zeros, but may also change existing CFL calculations, and may report a regression in `ocean.stats`. - Rotated diagnostic checksum output is not tested, since there is not yet a way to associated rotationally equivalent diagnostics. See below for more information. Current limitations: - Only single PE runs can be rotated. Currently FMS assumes a specific ordering for assignment of PE IDs (east->west, south->north). An index rotation will typically re-orient these domains in a way which breaks this default assignment. This ID is used to manage MPI message passing targets, so any rearrangement of these IDs will cause errors. Since we currently cannot control the PE ID assigned by FMS, we are currently unable to support index rotation of parallel runs. - Certain fields and tracers cannot be rotated. There are a small subset of tracers and fields in various structures, such as boundary fluxes, which are currently unsupported. This is primarily beacuse these tracers are typically managed at the driver level. There is no reason why these fields cannot be supported, but it would require a larger test suite to detect and handle such fields. - Diagnostic output is not rotated. Diagnostics are computed on the rotated grid, but it would require additional FMS wrappers to support registering and writing diagnostics on the input index map. This is not yet implemented, so all diagnostics are on the rotated index map. One additional consequence is that there is no way to register pairs of diagnostics, and thus no way to automate the chksum.diag output. Currently, diagnostic checksums are disabled in the test suite. We hope to resolve this issue in a future patch. - Open boundary condition (OBC) rotation is restriced to INDEX_TURNS=1 Generalized OBC rotation is currently not supported. This is primarily due to the sensitivity of segment configuration, which is specified with a large number of flags denoting its orientation. It is possible to support generalized rotation, but it will require a refactor of the OBC segment code. We hope to support generalized rotation in a future patch. - Incorrect definitions of gridLonT and gridLatT Due to certain array length assumptions for 1d axes, we rotate and exchange the values of gridLatT and gridLonT during quarter-turn operations. This is not correct, since these arrays describe latitude and longitude, rather than the axes in the first and second dimension. However, several other components currently expect the first and second reference axis to have matching array lengths, so for now we swap these arrays during rotations. The 1d arrays are only used for initialization computation (which is on the input map) and I/O management, so this error does not affect any existing runs. But rotated runs which save these arrays will be incorrect. - Non-ALE sponge rotation is disabled. Only ALE sponge rotation is currently supported. It should be possible to extend rotation to include non-ALE sponges if needed. Further comments: - Fields are not rotated in-place, since many calculations require that both fields exist at any time. While it is unlikely that rotated and unrotated fields would persist for an entire run, there is likely to be an increase in memory overhead. - External fields from the drivers are rotated and unrotated at the beginning and end of every timestep, which can create additional computational overhead. Note that there are control flags, e.g. `cycle_start` and `cycle_end` which could be used to manage these operations, assuming that the driver does not change the fields inbetween coupler steps. - This patch fixes what appears to have been an error in the global h-point indexes of OBC segments. However, it also seems that these indices were unused, so this is unlikely to impact existing runs. This implementation was proposed by Robert Hallberg and follows an earlier implementation by Nic Hannah, whose efforts introduced several changes that implemented the rotational invariance of existing numerical calculations. --- .testing/Makefile | 12 +- .testing/tc2/MOM_input | 1 + src/core/MOM.F90 | 338 +++++++++-- src/core/MOM_barotropic.F90 | 34 +- src/core/MOM_dynamics_split_RK2.F90 | 40 +- src/core/MOM_forcing_type.F90 | 379 +++++++++++- src/core/MOM_open_boundary.F90 | 567 ++++++++++++++++-- src/core/MOM_transcribe_grid.F90 | 92 ++- src/core/MOM_variables.F90 | 76 +++ src/diagnostics/MOM_debugging.F90 | 4 +- src/diagnostics/MOM_sum_output.F90 | 21 +- src/framework/MOM_array_transform.F90 | 358 +++++++++++ src/framework/MOM_checksums.F90 | 492 ++++++++++++--- src/framework/MOM_domains.F90 | 73 ++- src/framework/MOM_dyn_horgrid.F90 | 2 +- src/framework/MOM_hor_index.F90 | 53 +- src/framework/MOM_horizontal_regridding.F90 | 10 +- src/framework/MOM_restart.F90 | 115 +++- src/framework/MOM_transform_FMS.F90 | 399 ++++++++++++ src/initialization/MOM_grid_initialize.F90 | 6 +- .../MOM_shared_initialization.F90 | 3 + src/parameterizations/lateral/MOM_MEKE.F90 | 9 +- .../lateral/MOM_lateral_mixing_coeffs.F90 | 9 +- .../lateral/MOM_thickness_diffuse.F90 | 3 +- .../vertical/MOM_ALE_sponge.F90 | 159 +++++ .../vertical/MOM_set_diffusivity.F90 | 13 +- .../vertical/MOM_set_viscosity.F90 | 11 +- .../vertical/MOM_vert_friction.F90 | 12 +- src/tracer/MOM_tracer_hor_diff.F90 | 6 +- 29 files changed, 2981 insertions(+), 316 deletions(-) create mode 100644 src/framework/MOM_array_transform.F90 create mode 100644 src/framework/MOM_transform_FMS.F90 diff --git a/.testing/Makefile b/.testing/Makefile index 8067e4218d..0d73979204 100644 --- a/.testing/Makefile +++ b/.testing/Makefile @@ -40,7 +40,7 @@ MKMF_TEMPLATE ?= build/mkmf/templates/ncrc-gnu.mk # Executables BUILDS = symmetric asymmetric repro openmp CONFIGS := $(wildcard tc*) -TESTS = grids layouts restarts nans dims openmps +TESTS = grids layouts restarts nans dims openmps rotations # REPRO tests enable reproducibility with optimization, and often do not match # the DEBUG results in older GCCs and vendor compilers, so we can optionally @@ -186,9 +186,15 @@ test: $(foreach t,$(TESTS),test.$(t)) # NOTE: We remove tc3 (OBC) from grid test since it cannot run asymmetric grids +# NOTE: rotation diag chksum disabled since we cannot yet compare rotationally +# equivalent diagnostics + +# TODO: restart checksum comparison is not yet implemented + .PHONY: $(foreach t,$(TESTS),test.$(t)) test.grids: $(foreach c,$(filter-out tc3,$(CONFIGS)),$(c).grid $(c).grid.diag) test.layouts: $(foreach c,$(CONFIGS),$(c).layout $(c).layout.diag) +test.rotations: $(foreach c,$(CONFIGS),$(c).rotate) test.restarts: $(foreach c,$(CONFIGS),$(c).restart) test.repros: $(foreach c,$(CONFIGS),$(c).repro $(c).repro.diag) test.openmps: $(foreach c,$(CONFIGS),$(c).openmp $(c).openmp.diag) @@ -210,6 +216,7 @@ endef $(eval $(call CMP_RULE,grid,symmetric asymmetric)) $(eval $(call CMP_RULE,layout,symmetric layout)) +$(eval $(call CMP_RULE,rotate,symmetric rotate)) $(eval $(call CMP_RULE,repro,symmetric repro)) $(eval $(call CMP_RULE,openmp,symmetric openmp)) $(eval $(call CMP_RULE,nan,symmetric nan)) @@ -260,7 +267,7 @@ results/%/ocean.stats.$(1): build/$(2)/MOM6 cp -rL $$*/* work/$$*/$(1) cd work/$$*/$(1) && if [ -f Makefile ]; then make; fi mkdir -p work/$$*/$(1)/RESTART - echo $(4) > work/$$*/$(1)/MOM_override + echo -e "$(4)" > work/$$*/$(1)/MOM_override cd work/$$*/$(1) && $$(call MPIRUN_CMD,$(5)) -n $(6) ../../../$$< 2> debug.out > std.out \ || ! sed 's/^/$$*.$(1): /' std.out debug.out \ && sed 's/^/$$*.$(1): /' std.out @@ -282,6 +289,7 @@ $(eval $(call STAT_RULE,target,target,,,,1)) $(eval $(call STAT_RULE,repro,repro,,,,1)) $(eval $(call STAT_RULE,openmp,openmp,,,,1)) $(eval $(call STAT_RULE,layout,symmetric,,LAYOUT=2$(,)1,,2)) +$(eval $(call STAT_RULE,rotate,symmetric,,ROTATE_INDEX=True\nINDEX_TURNS=1,,1)) $(eval $(call STAT_RULE,nan,symmetric,,,MALLOC_PERTURB_=256,1)) $(eval $(call STAT_RULE,dim.t,symmetric,,T_RESCALE_POWER=11,,1)) $(eval $(call STAT_RULE,dim.l,symmetric,,L_RESCALE_POWER=11,,1)) diff --git a/.testing/tc2/MOM_input b/.testing/tc2/MOM_input index c037648d95..285ee79e4b 100644 --- a/.testing/tc2/MOM_input +++ b/.testing/tc2/MOM_input @@ -600,3 +600,4 @@ ENERGYSAVEDAYS = 0.5 ! [days] default = 3600.0 ! energies of the run and other globally summed diagnostics. DIAG_AS_CHKSUM = True DEBUG = True +USE_GM_WORK_BUG = False diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index 78d53e0b76..21e23d69cf 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -4,10 +4,12 @@ module MOM ! This file is part of MOM6. See LICENSE.md for the license. ! Infrastructure modules +use MOM_array_transform, only : rotate_array, rotate_vector use MOM_debugging, only : MOM_debugging_init, hchksum, uvchksum use MOM_debugging, only : check_redundant use MOM_checksum_packages, only : MOM_thermo_chksum, MOM_state_chksum use MOM_checksum_packages, only : MOM_accel_chksum, MOM_surface_chksum +use MOM_coms, only : num_PEs 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 @@ -37,7 +39,8 @@ module MOM use MOM_io, only : MOM_io_init, vardesc, var_desc use MOM_io, only : slasher, file_exists, MOM_read_data use MOM_obsolete_params, only : find_obsolete_params -use MOM_restart, only : register_restart_field, query_initialized, save_restart +use MOM_restart, only : register_restart_field, register_restart_pair +use MOM_restart, only : query_initialized, save_restart use MOM_restart, only : restart_init, is_new_run, MOM_restart_CS use MOM_spatial_means, only : global_mass_integral use MOM_time_manager, only : time_type, real_to_time, time_type_to_real, operator(+) @@ -50,6 +53,7 @@ module MOM use MOM_ALE, only : ALE_init, ALE_end, ALE_main, ALE_CS, adjustGridForIntegrity 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_ALE_sponge, only : rotate_ALE_sponge, update_ALE_sponge_field use MOM_barotropic, only : Barotropic_CS use MOM_boundary_update, only : call_OBC_register, OBC_register_end, update_OBC_CS use MOM_coord_initialization, only : MOM_initialize_coord @@ -72,9 +76,13 @@ module MOM use MOM_dyn_horgrid, only : dyn_horgrid_type, create_dyn_horgrid, destroy_dyn_horgrid use MOM_EOS, only : EOS_init, calculate_density, calculate_TFreeze use MOM_fixed_initialization, only : MOM_initialize_fixed +use MOM_forcing_type, only : allocate_forcing_type, allocate_mech_forcing +use MOM_forcing_type, only : deallocate_mech_forcing, deallocate_forcing_type +use MOM_forcing_type, only : rotate_forcing, rotate_mech_forcing use MOM_grid, only : ocean_grid_type, MOM_grid_init, MOM_grid_end use MOM_grid, only : set_first_direction, rescale_grid_bathymetry use MOM_hor_index, only : hor_index_type, hor_index_init +use MOM_hor_index, only : rotate_hor_index 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, calc_depth_function, VarMix_CS @@ -87,6 +95,7 @@ module MOM use MOM_open_boundary, only : register_temp_salt_segments use MOM_open_boundary, only : open_boundary_register_restarts use MOM_open_boundary, only : update_segment_tracer_reservoirs +use MOM_open_boundary, only : rotate_OBC_config, rotate_OBC_init 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 @@ -108,11 +117,13 @@ module MOM use MOM_tracer_flow_control, only : tracer_flow_control_init, call_tracer_surface_state use MOM_tracer_flow_control, only : tracer_flow_control_end use MOM_transcribe_grid, only : copy_dyngrid_to_MOM_grid, copy_MOM_grid_to_dyngrid +use MOM_transcribe_grid, only : rotate_dyngrid use MOM_unit_scaling, only : unit_scale_type, unit_scaling_init use MOM_unit_scaling, only : unit_scaling_end, fix_restart_unit_scaling 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_variables, only : rotate_surface_state use MOM_verticalGrid, only : verticalGrid_type, verticalGridInit, verticalGridEnd use MOM_verticalGrid, only : fix_restart_scaling use MOM_verticalGrid, only : get_thickness_units, get_flux_units, get_tr_flux_units @@ -180,7 +191,10 @@ module MOM real :: time_in_thermo_cycle !< The running time of the current time-stepping !! cycle in calls that step the thermodynamics [T ~> s]. - type(ocean_grid_type) :: G !< structure containing metrics and grid info + type(ocean_grid_type) :: G_in !< Input grid metric + type(ocean_grid_type), pointer :: G => NULL() !< Model grid metric + logical :: rotate_index = .false. !< True if index map is rotated + type(verticalGrid_type), pointer :: & GV => NULL() !< structure containing vertical grid info type(unit_scale_type), pointer :: & @@ -399,13 +413,13 @@ module MOM !! 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_int_in, CS, & +subroutine step_MOM(forces_in, fluxes_in, sfc_state, Time_start, time_int_in, CS, & 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, + type(mech_forcing), target, intent(inout) :: forces_in !< A structure with the driving mechanical forces + type(forcing), target, intent(inout) :: fluxes_in !< A structure with pointers to themodynamic, !! tracer and mass exchange forcing fields - type(surface), intent(inout) :: sfc_state !< surface ocean state + type(surface), target, 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_int_in !< time interval covered by this run segment [s]. type(MOM_control_struct), pointer :: CS !< control structure from initialize_MOM @@ -430,6 +444,7 @@ subroutine step_MOM(forces, fluxes, sfc_state, Time_start, time_int_in, CS, & ! local variables type(ocean_grid_type), pointer :: G => NULL() ! pointer to a structure containing ! metrics and related information + type(ocean_grid_type), pointer :: G_in => NULL() ! Input grid metric type(verticalGrid_type), pointer :: GV => NULL() ! Pointer to the vertical grid structure type(unit_scale_type), pointer :: US => NULL() ! Pointer to a structure containing ! various unit conversion factors @@ -480,7 +495,13 @@ subroutine step_MOM(forces, fluxes, sfc_state, Time_start, time_int_in, CS, & type(group_pass_type) :: pass_tau_ustar_psurf logical :: showCallTree - G => CS%G ; GV => CS%GV ; US => CS%US + ! External forcing fields on the model index map + type(mech_forcing), pointer :: forces ! Mechanical forcing + type(forcing), pointer :: fluxes ! Boundary fluxes + type(surface), pointer :: sfc_state_diag ! Surface boundary fields + integer :: turns ! Number of quarter turns from input to model indexing + + G => CS%G ; G_in => CS%G_in ; GV => CS%GV ; US => CS%US 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 @@ -507,6 +528,21 @@ subroutine step_MOM(forces, fluxes, sfc_state, Time_start, time_int_in, CS, & showCallTree = callTree_showQuery() if (showCallTree) call callTree_enter("step_MOM(), MOM.F90") + ! Rotate the forces from G_in to G + if (CS%rotate_index) then + turns = G%HI%turns + allocate(forces) + call allocate_mech_forcing(forces_in, G, forces) + call rotate_mech_forcing(forces_in, turns, forces) + + allocate(fluxes) + call allocate_forcing_type(fluxes_in, G, fluxes) + call rotate_forcing(fluxes_in, fluxes, turns) + else + forces => forces_in + fluxes => fluxes_in + endif + ! First determine the time step that is consistent with this call and an ! integer fraction of time_interval. if (do_dyn) then @@ -838,19 +874,27 @@ subroutine step_MOM(forces, fluxes, sfc_state, Time_start, time_int_in, CS, & endif if (showCallTree) call callTree_waypoint("calling extract_surface_state (step_MOM)") + ! NOTE: sfc_state uses input indexing, since it is also used by drivers. call extract_surface_state(CS, sfc_state) ! Do diagnostics that only occur at the end of a complete forcing step. if (cycle_end) then + if (CS%rotate_index) then + allocate(sfc_state_diag) + call rotate_surface_state(sfc_state, G_in, sfc_state_diag, G, turns) + else + sfc_state_diag => sfc_state + endif + call cpu_clock_begin(id_clock_diagnostics) if (CS%time_in_cycle > 0.0) then call enable_averages(CS%time_in_cycle, Time_local, CS%diag) - call post_surface_dyn_diags(CS%sfc_IDs, G, CS%diag, sfc_state, ssh) + call post_surface_dyn_diags(CS%sfc_IDs, G, CS%diag, sfc_state_diag, ssh) endif if (CS%time_in_thermo_cycle > 0.0) then call enable_averages(CS%time_in_thermo_cycle, Time_local, CS%diag) call post_surface_thermo_diags(CS%sfc_IDs, G, GV, US, CS%diag, CS%time_in_thermo_cycle, & - sfc_state, CS%tv, ssh, CS%ave_ssh_ibc) + sfc_state_diag, CS%tv, ssh, CS%ave_ssh_ibc) endif call disable_averaging(CS%diag) call cpu_clock_end(id_clock_diagnostics) @@ -868,6 +912,17 @@ subroutine step_MOM(forces, fluxes, sfc_state, Time_start, time_int_in, CS, & call cpu_clock_end(id_clock_other) + ! De-rotate fluxes and copy back to the input, since they can be changed. + if (CS%rotate_index) then + call rotate_forcing(fluxes, fluxes_in, -turns) + + call deallocate_mech_forcing(forces) + deallocate(forces) + + call deallocate_forcing_type(fluxes) + deallocate(fluxes) + endif + if (showCallTree) call callTree_leave("step_MOM()") call cpu_clock_end(id_clock_ocean) @@ -1531,13 +1586,24 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & !! calls to step_MOM instead of the number of !! dynamics timesteps. ! local variables - type(ocean_grid_type), pointer :: G => NULL() ! A pointer to a structure with metrics and related - type(hor_index_type) :: HI ! A hor_index_type for array extents + type(ocean_grid_type), pointer :: G => NULL() ! A pointer to the metric grid use for the run + type(ocean_grid_type), pointer :: G_in => NULL() ! Pointer to the input grid + type(hor_index_type), pointer :: HI => NULL() ! A hor_index_type for array extents + type(hor_index_type), target :: HI_in ! HI on the input grid type(verticalGrid_type), pointer :: GV => NULL() type(dyn_horgrid_type), pointer :: dG => NULL() + type(dyn_horgrid_type), pointer :: dG_in => NULL() type(diag_ctrl), pointer :: diag => NULL() type(unit_scale_type), pointer :: US => NULL() character(len=4), parameter :: vers_num = 'v2.0' + integer :: turns ! Number of grid quarter-turns + + ! Initial state on the input index map + real, allocatable, dimension(:,:,:) :: u_in, v_in, h_in + real, allocatable, dimension(:,:,:), target :: T_in, S_in + type(ocean_OBC_type), pointer :: OBC_in => NULL() + type(sponge_CS), pointer :: sponge_in_CSp => NULL() + type(ALE_sponge_CS), pointer :: ALE_sponge_in_CSp => NULL() ! This include declares and sets the variable "version". # include "version_variable.h" @@ -1608,9 +1674,6 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & endif allocate(CS) - if (test_grid_copy) then ; allocate(G) - else ; G => CS%G ; endif - CS%Time => Time id_clock_init = cpu_clock_id('Ocean Initialization', grain=CLOCK_SUBCOMPONENT) @@ -1949,31 +2012,95 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & call callTree_waypoint("MOM parameters read (initialize_MOM)") + ! Grid rotation test + call get_param(param_file, "MOM", "ROTATE_INDEX", CS%rotate_index, & + "Enable rotation of the horizontal indices.", default=.false.) + if (CS%rotate_index) then + ! TODO: Index rotation currently only works when index rotation does not + ! change the MPI rank of each domain. Resolving this will require a + ! modification to FMS PE assignment. + ! For now, we only permit single-core runs. + + if (num_PEs() /= 1) & + call MOM_error(FATAL, "Index rotation is only supported on one PE.") + + call get_param(param_file, "MOM", "INDEX_TURNS", turns, & + "Number of counterclockwise quarter-turn index rotations.", default=1) + endif + ! Set up the model domain and grids. #ifdef SYMMETRIC_MEMORY_ symmetric = .true. #else symmetric = .false. #endif + G_in => CS%G_in #ifdef STATIC_MEMORY_ - call MOM_domains_init(G%domain, param_file, symmetric=symmetric, & + call MOM_domains_init(G_in%domain, param_file, symmetric=symmetric, & static_memory=.true., NIHALO=NIHALO_, NJHALO=NJHALO_, & NIGLOBAL=NIGLOBAL_, NJGLOBAL=NJGLOBAL_, NIPROC=NIPROC_, & NJPROC=NJPROC_) #else - call MOM_domains_init(G%domain, param_file, symmetric=symmetric) + call MOM_domains_init(G_in%domain, param_file, symmetric=symmetric, & + domain_name="MOM_in") #endif + + ! Copy input grid (G_in) domain to active grid G + ! Swap axes for quarter and 3-quarter turns + if (CS%rotate_index) then + allocate(CS%G) + call clone_MOM_domain(G_in%Domain, CS%G%Domain, turns=turns) + first_direction = modulo(first_direction + turns, 2) + else + CS%G => G_in + endif + + ! TODO: It is unlikey that test_grid_copy and rotate_index would work at the + ! same time. It may be possible to enable both but for now we prevent it. + if (test_grid_copy .and. CS%rotate_index) & + call MOM_error(FATAL, "Grid cannot be copied during index rotation.") + + if (test_grid_copy) then ; allocate(G) + else ; G => CS%G ; endif + call callTree_waypoint("domains initialized (initialize_MOM)") call MOM_debugging_init(param_file) call diag_mediator_infrastructure_init() call MOM_io_init(param_file) - call hor_index_init(G%Domain, HI, param_file, & + ! Create HI and dG on the input index map. + call hor_index_init(G_in%Domain, HI_in, param_file, & local_indexing=.not.global_indexing) + call create_dyn_horgrid(dG_in, HI_in, bathymetry_at_vel=bathy_at_vel) + call clone_MOM_domain(G_in%Domain, dG_in%Domain) + + ! Allocate initialize time-invariant MOM variables. + call MOM_initialize_fixed(dG_in, US, OBC_in, param_file, write_geom_files, & + dirs%output_directory) + + call callTree_waypoint("returned from MOM_initialize_fixed() (initialize_MOM)") - call create_dyn_horgrid(dG, HI, bathymetry_at_vel=bathy_at_vel) - call clone_MOM_domain(G%Domain, dG%Domain) + ! Determine HI and dG for the model index map. + if (CS%rotate_index) then + allocate(HI) + call rotate_hor_index(HI_in, turns, HI) + call create_dyn_horgrid(dG, HI, bathymetry_at_vel=bathy_at_vel) + call clone_MOM_domain(G%Domain, dG%Domain) + call rotate_dyngrid(dG_in, dG, US, turns) + if (associated(OBC_in)) then + ! TODO: General OBC index rotations is not yet supported. + if (modulo(turns, 4) /= 1) & + call MOM_error(FATAL, "OBC index rotation of 180 and 270 degrees is " & + // "not yet unsupported.") + allocate(CS%OBC) + call rotate_OBC_config(OBC_in, dG_in, CS%OBC, dG, turns) + endif + else + HI => HI_in + dG => dG_in + CS%OBC => OBC_in + endif call verticalGridInit( param_file, CS%GV, US ) GV => CS%GV @@ -1986,10 +2113,6 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & call MOM_timing_init(CS) - ! Allocate initialize time-invariant MOM variables. - call MOM_initialize_fixed(dG, US, CS%OBC, param_file, write_geom_files, dirs%output_directory) - call callTree_waypoint("returned from MOM_initialize_fixed() (initialize_MOM)") - if (associated(CS%OBC)) call call_OBC_register(param_file, CS%update_OBC_CSp, CS%OBC) call tracer_registry_init(param_file, CS%tracer_Reg) @@ -2045,6 +2168,18 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & flux_scale=conv2salt, convergence_units='kg m-2 s-1', & convergence_scale=0.001*GV%H_to_kg_m2, CMOR_tendprefix="osalt", diag_form=2) endif + ! NOTE: register_temp_salt_segments includes allocation of tracer fields + ! along segments. Bit reproducibility requires that MOM_initialize_state + ! be called on the input index map, so we must setup both OBC and OBC_in. + ! + ! XXX: This call on OBC_in allocates the tracer fields on the unrotated + ! grid, but also incorrectly stores a pointer to a tracer_type for the + ! rotated registry (e.g. segment%tr_reg%Tr(n)%Tr) from CS%tracer_reg. + ! + ! While incorrect and potentially dangerous, it does not seem that this + ! pointer is used during initialization, so we leave it for now. + if (CS%rotate_index .and. associated(OBC_in)) & + call register_temp_salt_segments(GV, OBC_in, CS%tracer_Reg, param_file) if (associated(CS%OBC)) & call register_temp_salt_segments(GV, CS%OBC, CS%tracer_Reg, param_file) endif @@ -2161,9 +2296,17 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & ! (potentially static) ocean-specific grid type. ! The next line would be needed if G%Domain had not already been init'd above: ! call clone_MOM_domain(dG%Domain, G%Domain) - call MOM_grid_init(G, param_file, US, HI, bathymetry_at_vel=bathy_at_vel) - call copy_dyngrid_to_MOM_grid(dG, G, US) - call destroy_dyn_horgrid(dG) + + ! NOTE: If indices are rotated, then G and G_in must both be initialized. + ! If not rotated, then G_in and G are the same grid. + if (CS%rotate_index) then + call MOM_grid_init(G, param_file, US, HI, bathymetry_at_vel=bathy_at_vel) + call copy_dyngrid_to_MOM_grid(dG, G, US) + call destroy_dyn_horgrid(dG) + endif + call MOM_grid_init(G_in, param_file, US, HI_in, bathymetry_at_vel=bathy_at_vel) + call copy_dyngrid_to_MOM_grid(dG_in, G_in, US) + call destroy_dyn_horgrid(dG_in) ! Set a few remaining fields that are specific to the ocean grid type. call set_first_direction(G, first_direction) @@ -2175,9 +2318,68 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & ! Consider removing this later? G%ke = GV%ke - call MOM_initialize_state(CS%u, CS%v, CS%h, CS%tv, Time, G, GV, US, param_file, & - dirs, restart_CSp, CS%ALE_CSp, CS%tracer_Reg, & - CS%sponge_CSp, CS%ALE_sponge_CSp, CS%OBC, Time_in) + if (CS%rotate_index) then + G_in%ke = GV%ke + + allocate(u_in(G_in%IsdB:G_in%IedB, G_in%jsd:G_in%jed, nz)) + allocate(v_in(G_in%isd:G_in%ied, G_in%JsdB:G_in%JedB, nz)) + allocate(h_in(G_in%isd:G_in%ied, G_in%jsd:G_in%jed, nz)) + u_in(:,:,:) = 0.0 + v_in(:,:,:) = 0.0 + h_in(:,:,:) = GV%Angstrom_H + + if (use_temperature) then + allocate(T_in(G_in%isd:G_in%ied, G_in%jsd:G_in%jed, nz)) + allocate(S_in(G_in%isd:G_in%ied, G_in%jsd:G_in%jed, nz)) + T_in(:,:,:) = 0.0 + S_in(:,:,:) = 0.0 + + CS%tv%T => T_in + CS%tv%S => S_in + endif + + call MOM_initialize_state(u_in, v_in, h_in, CS%tv, Time, G_in, GV, US, & + param_file, dirs, restart_CSp, CS%ALE_CSp, CS%tracer_Reg, & + sponge_in_CSp, ALE_sponge_in_CSp, OBC_in, Time_in) + + if (use_temperature) then + CS%tv%T => CS%T + CS%tv%S => CS%S + endif + + call rotate_initial_state(u_in, v_in, h_in, T_in, S_in, use_temperature, & + turns, CS%u, CS%v, CS%h, CS%T, CS%S) + + if (associated(sponge_in_CSp)) then + ! TODO: Implementation and testing of non-ALE spong rotation + call MOM_error(FATAL, "Index rotation of non-ALE sponge is not yet " & + // "implemented.") + endif + + if (associated(ALE_sponge_in_CSp)) then + call rotate_ALE_sponge(ALE_sponge_in_CSp, G_in, CS%ALE_sponge_CSp, G, & + turns, param_file) + call update_ALE_sponge_field(CS%ALE_sponge_CSp, T_in, CS%T) + call update_ALE_sponge_field(CS%ALE_sponge_CSp, S_in, CS%S) + endif + + if (associated(OBC_in)) & + call rotate_OBC_init(OBC_in, G, GV, US, param_file, CS%tv, restart_CSp, & + CS%OBC) + + deallocate(u_in) + deallocate(v_in) + deallocate(h_in) + if (use_temperature) then + deallocate(T_in) + deallocate(S_in) + endif + else + call MOM_initialize_state(CS%u, CS%v, CS%h, CS%tv, Time, G, GV, US, & + param_file, dirs, restart_CSp, CS%ALE_CSp, CS%tracer_Reg, & + CS%sponge_CSp, CS%ALE_sponge_CSp, CS%OBC, Time_in) + endif + call cpu_clock_end(id_clock_MOM_init) call callTree_waypoint("returned from MOM_initialize_state() (initialize_MOM)") @@ -2469,7 +2671,7 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & CS%nstep_tot = 0 if (present(count_calls)) CS%count_calls = count_calls - call MOM_sum_output_init(G, US, param_file, dirs%output_directory, & + call MOM_sum_output_init(G_in, US, param_file, dirs%output_directory, & CS%ntrunc, Time_init, CS%sum_output_CSp) ! Flag whether to save initial conditions in finish_MOM_initialization() or not. @@ -2526,7 +2728,7 @@ subroutine finish_MOM_initialization(Time, dirs, CS, restart_CSp) call register_restart_field(z_interface, "eta", .true., restart_CSp_tmp, & "Interface heights", "meter", z_grid='i') - call save_restart(dirs%output_directory, Time, G, & + call save_restart(dirs%output_directory, Time, CS%G_in, & restart_CSp_tmp, filename=CS%IC_file, GV=GV) deallocate(z_interface) deallocate(restart_CSp_tmp) @@ -2617,17 +2819,20 @@ subroutine set_restart_fields(GV, US, param_file, CS, restart_CSp) type(verticalGrid_type), intent(inout) :: GV !< ocean vertical grid structure type(unit_scale_type), intent(inout) :: US !< A dimensional unit scaling type type(param_file_type), intent(in) :: param_file !< opened file for parsing to get parameters - type(MOM_control_struct), intent(in) :: CS !< control structure set up by inialize_MOM + type(MOM_control_struct), intent(in) :: CS !< control structure set up by initialize_MOM type(MOM_restart_CS), pointer :: restart_CSp !< pointer to the restart control !! structure that will be used for MOM. ! Local variables logical :: use_ice_shelf ! Needed to determine whether to add CS%Hml to restarts character(len=48) :: thickness_units, flux_units - + type(vardesc) :: u_desc, v_desc thickness_units = get_thickness_units(GV) flux_units = get_flux_units(GV) + u_desc = var_desc("u", "m s-1", "Zonal velocity", hor_grid='Cu') + v_desc = var_desc("v", "m s-1", "Meridional velocity", hor_grid='Cv') + if (associated(CS%tv%T)) & call register_restart_field(CS%tv%T, "Temp", .true., restart_CSp, & "Potential Temperature", "degC") @@ -2638,11 +2843,7 @@ subroutine set_restart_fields(GV, US, param_file, CS, restart_CSp) call register_restart_field(CS%h, "h", .true., restart_CSp, & "Layer Thickness", thickness_units) - call register_restart_field(CS%u, "u", .true., restart_CSp, & - "Zonal velocity", "m s-1", hor_grid='Cu') - - call register_restart_field(CS%v, "v", .true., restart_CSp, & - "Meridional velocity", "m s-1", hor_grid='Cv') + call register_restart_pair(CS%u, CS%v, u_desc, v_desc, .true., restart_CSp) if (associated(CS%tv%frazil)) & call register_restart_field(CS%tv%frazil, "frazil", .false., restart_CSp, & @@ -2719,18 +2920,20 @@ end subroutine adjust_ssh_for_p_atm !> Set the surface (return) properties of the ocean model by !! setting the appropriate fields in sfc_state. Unused fields !! are set to NULL or are unallocated. -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 - !! data in this structure is intent out. +subroutine extract_surface_state(CS, sfc_state_in) + type(MOM_control_struct), pointer :: CS !< Master MOM control structure + type(surface), target, intent(inout) :: sfc_state_in !< transparent ocean surface state + !! structure shared with the calling routine + !! data in this structure is intent out. ! Local variables real :: hu, hv ! Thicknesses interpolated to velocity points [H ~> m or kg m-2] - type(ocean_grid_type), pointer :: G => NULL() !< 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(ocean_grid_type), pointer :: G_in => NULL() !< Input grid metric type(verticalGrid_type), pointer :: GV => NULL() !< structure containing vertical grid info type(unit_scale_type), pointer :: US => NULL() !< structure containing various unit conversion factors + type(surface), pointer :: sfc_state => NULL() ! surface state on the model grid real, dimension(:,:,:), pointer :: & h => NULL() !< h : layer thickness [H ~> m or kg m-2] real :: depth(SZI_(CS%G)) !< Distance from the surface in depth units [Z ~> m] or [H ~> m or kg m-2] @@ -2752,9 +2955,10 @@ subroutine extract_surface_state(CS, sfc_state) integer :: iscB, iecB, jscB, jecB, isdB, iedB, jsdB, jedB logical :: localError character(240) :: msg + integer :: turns ! Number of quarter turns call callTree_enter("extract_surface_state(), MOM.F90") - G => CS%G ; GV => CS%GV ; US => CS%US + G => CS%G ; G_in => CS%G_in ; GV => CS%GV ; US => CS%US is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed iscB = G%iscB ; iecB = G%iecB; jscB = G%jscB ; jecB = G%jecB @@ -2763,12 +2967,24 @@ subroutine extract_surface_state(CS, sfc_state) use_temperature = associated(CS%tv%T) - if (.not.sfc_state%arrays_allocated) then + turns = 0 + if (CS%rotate_index) & + turns = G%HI%turns + + if (.not.sfc_state_in%arrays_allocated) & ! Consider using a run-time flag to determine whether to do the vertical ! integrals, since the 3-d sums are not negligible in cost. - call allocate_surface_state(sfc_state, G, use_temperature, do_integrals=.true., & - omit_frazil=.not.associated(CS%tv%frazil)) + call allocate_surface_state(sfc_state_in, G_in, use_temperature, & + do_integrals=.true., omit_frazil=.not.associated(CS%tv%frazil)) + + if (CS%rotate_index) then + allocate(sfc_state) + call allocate_surface_state(sfc_state, G, use_temperature, & + do_integrals=.true., omit_frazil=.not.associated(CS%tv%frazil)) + else + sfc_state => sfc_state_in endif + sfc_state%T_is_conT = CS%tv%T_is_conT sfc_state%S_is_absS = CS%tv%S_is_absS @@ -3103,9 +3319,31 @@ subroutine extract_surface_state(CS, sfc_state) if (CS%debug) call MOM_surface_chksum("Post extract_sfc", sfc_state, G) + ! Rotate sfc_state back onto the input grid, sfc_state_in + if (CS%rotate_index) then + call rotate_surface_state(sfc_state, G, sfc_state_in, G_in, -turns) + call deallocate_surface_state(sfc_state) + endif + call callTree_leave("extract_surface_sfc_state()") end subroutine extract_surface_state +!> Rotate initialization fields from input to rotated arrays. +subroutine rotate_initial_state(u_in, v_in, h_in, T_in, S_in, & + use_temperature, turns, u, v, h, T, S) + real, dimension(:,:,:), intent(in) :: u_in, v_in, h_in, T_in, S_in + logical, intent(in) :: use_temperature + integer, intent(in) :: turns + real, dimension(:,:,:), intent(out) :: u, v, h, T, S + + call rotate_vector(u_in, v_in, turns, u, v) + call rotate_array(h_in, turns, h) + if (use_temperature) then + call rotate_array(T_in, turns, T) + call rotate_array(S_in, turns, S) + endif +end subroutine rotate_initial_state + !> Return true if all phases of step_MOM are at the same point in time. function MOM_state_is_synchronized(CS, adv_dyn) result(in_synch) type(MOM_control_struct), pointer :: CS !< MOM control structure @@ -3138,7 +3376,7 @@ subroutine get_MOM_state_elements(CS, G, GV, US, C_p, C_p_scaled, use_temp) !! units [Q degC-1 ~> J kg degC-1] logical, optional, intent(out) :: use_temp !< True if temperature is a state variable - if (present(G)) G => CS%G + if (present(G)) G => CS%G_in if (present(GV)) GV => CS%GV if (present(US)) US => CS%US if (present(C_p)) C_p = CS%US%Q_to_J_kg * CS%tv%C_p diff --git a/src/core/MOM_barotropic.F90 b/src/core/MOM_barotropic.F90 index 5998f08c16..4f7679b8e2 100644 --- a/src/core/MOM_barotropic.F90 +++ b/src/core/MOM_barotropic.F90 @@ -20,7 +20,8 @@ module MOM_barotropic use MOM_open_boundary, only : ocean_OBC_type, OBC_SIMPLE, OBC_NONE, open_boundary_query use MOM_open_boundary, only : OBC_DIRECTION_E, OBC_DIRECTION_W use MOM_open_boundary, only : OBC_DIRECTION_N, OBC_DIRECTION_S, OBC_segment_type -use MOM_restart, only : register_restart_field, query_initialized, MOM_restart_CS +use MOM_restart, only : register_restart_field, register_restart_pair +use MOM_restart, only : query_initialized, MOM_restart_CS use MOM_tidal_forcing, only : tidal_forcing_sensitivity, tidal_forcing_CS use MOM_time_manager, only : time_type, real_to_time, operator(+), operator(-) use MOM_unit_scaling, only : unit_scale_type @@ -1536,11 +1537,15 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, if (.not. use_BT_cont) then call uvchksum("BT Dat[uv]", Datu, Datv, CS%debug_BT_HI, haloshift=1, scale=US%L_to_m*GV%H_to_m) endif - call uvchksum("BT wt_[uv]", wt_u, wt_v, G%HI, 0, .true., .true.) - call uvchksum("BT frhat[uv]", CS%frhatu, CS%frhatv, G%HI, 0, .true., .true.) + call uvchksum("BT wt_[uv]", wt_u, wt_v, G%HI, haloshift=0, & + symmetric=.true., omit_corners=.true., scalar_pair=.true.) + call uvchksum("BT frhat[uv]", CS%frhatu, CS%frhatv, G%HI, haloshift=0, & + symmetric=.true., omit_corners=.true., scalar_pair=.true.) call uvchksum("BT bc_accel_[uv]", bc_accel_u, bc_accel_v, G%HI, haloshift=0, scale=US%L_T2_to_m_s2) - call uvchksum("BT IDat[uv]", CS%IDatu, CS%IDatv, G%HI, haloshift=0, scale=US%m_to_Z) - call uvchksum("BT visc_rem_[uv]", visc_rem_u, visc_rem_v, G%HI, haloshift=1) + call uvchksum("BT IDat[uv]", CS%IDatu, CS%IDatv, G%HI, haloshift=0, & + scale=US%m_to_Z, scalar_pair=.true.) + call uvchksum("BT visc_rem_[uv]", visc_rem_u, visc_rem_v, G%HI, & + haloshift=1, scalar_pair=.true.) endif if (query_averaging_enabled(CS%diag)) then @@ -3113,9 +3118,13 @@ subroutine btcalc(h, G, GV, CS, h_u, h_v, may_use_default, OBC) enddo ; endif if (CS%debug) then - call uvchksum("btcalc frhat[uv]", CS%frhatu, CS%frhatv, G%HI, 0, .true., .true.) + call uvchksum("btcalc frhat[uv]", CS%frhatu, CS%frhatv, G%HI, & + haloshift=0, symmetric=.true., omit_corners=.true., & + scalar_pair=.true.) if (present(h_u) .and. present(h_v)) & - call uvchksum("btcalc h_[uv]", h_u, h_v, G%HI, 0, .true., .true., scale=GV%H_to_m) + call uvchksum("btcalc h_[uv]", h_u, h_v, G%HI, haloshift=0, & + symmetric=.true., omit_corners=.true., scale=GV%H_to_m, & + scalar_pair=.true.) call hchksum(h, "btcalc h",G%HI, haloshift=1, scale=GV%H_to_m) endif @@ -4235,6 +4244,7 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, CS%debug_BT_HI%IedB=CS%iedw CS%debug_BT_HI%JsdB=CS%jsdw-1 CS%debug_BT_HI%JedB=CS%jedw + CS%debug_BT_HI%turns = G%HI%turns endif ! IareaT, IdxCu, and IdyCv need to be allocated with wide halos. @@ -4607,6 +4617,7 @@ subroutine register_barotropic_restarts(HI, GV, param_file, CS, restart_CS) type(vardesc) :: vd(3) real :: slow_rate integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB + isd = HI%isd ; ied = HI%ied ; jsd = HI%jsd ; jed = HI%jed IsdB = HI%IsdB ; IedB = HI%IedB ; JsdB = HI%JsdB ; JedB = HI%JedB @@ -4628,8 +4639,7 @@ subroutine register_barotropic_restarts(HI, GV, param_file, CS, restart_CS) hor_grid='u', z_grid='1') vd(3) = var_desc("vbtav","m s-1","Time mean barotropic meridional velocity",& hor_grid='v', z_grid='1') - call register_restart_field(CS%ubtav, vd(2), .false., restart_CS) - call register_restart_field(CS%vbtav, vd(3), .false., restart_CS) + call register_restart_pair(CS%ubtav, CS%vbtav, vd(2), vd(3), .false., restart_CS) vd(2) = var_desc("ubt_IC", "m s-1", & longname="Next initial condition for the barotropic zonal velocity", & @@ -4637,8 +4647,7 @@ subroutine register_barotropic_restarts(HI, GV, param_file, CS, restart_CS) vd(3) = var_desc("vbt_IC", "m s-1", & longname="Next initial condition for the barotropic meridional velocity",& hor_grid='v', z_grid='1') - call register_restart_field(CS%ubt_IC, vd(2), .false., restart_CS) - call register_restart_field(CS%vbt_IC, vd(3), .false., restart_CS) + call register_restart_pair(CS%ubt_IC, CS%vbt_IC, vd(2), vd(3), .false., restart_CS) if (GV%Boussinesq) then vd(2) = var_desc("uhbt_IC", "m3 s-1", & @@ -4655,8 +4664,7 @@ subroutine register_barotropic_restarts(HI, GV, param_file, CS, restart_CS) longname="Next initial condition for the barotropic meridional transport",& hor_grid='v', z_grid='1') endif - 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_pair(CS%uhbt_IC, CS%vhbt_IC, vd(2), vd(3), .false., restart_CS) call register_restart_field(CS%dtbt, "DTBT", .false., restart_CS, & longname="Barotropic timestep", units="seconds") diff --git a/src/core/MOM_dynamics_split_RK2.F90 b/src/core/MOM_dynamics_split_RK2.F90 index 8c0decd8c1..62cff69a8c 100644 --- a/src/core/MOM_dynamics_split_RK2.F90 +++ b/src/core/MOM_dynamics_split_RK2.F90 @@ -28,7 +28,8 @@ module MOM_dynamics_split_RK2 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, var_desc -use MOM_restart, only : register_restart_field, query_initialized, save_restart +use MOM_restart, only : register_restart_field, register_restart_pair +use MOM_restart, only : query_initialized, save_restart use MOM_restart, only : restart_init, is_new_run, MOM_restart_CS use MOM_time_manager, only : time_type, time_type_to_real, operator(+) use MOM_time_manager, only : operator(-), operator(>), operator(*), operator(/) @@ -886,11 +887,12 @@ subroutine register_restarts_dyn_split_RK2(HI, GV, param_file, CS, restart_CS, u real, dimension(SZI_(HI),SZJB_(HI),SZK_(GV)), & target, intent(inout) :: vh !< merid volume/mass transport [H L2 T-1 ~> m3 s-1 or kg s-1] - type(vardesc) :: vd + type(vardesc) :: vd(2) character(len=40) :: mdl = "MOM_dynamics_split_RK2" ! This module's name. character(len=48) :: thickness_units, flux_units integer :: isd, ied, jsd, jed, nz, IsdB, IedB, JsdB, JedB + isd = HI%isd ; ied = HI%ied ; jsd = HI%jsd ; jed = HI%jed ; nz = GV%ke IsdB = HI%IsdB ; IedB = HI%IedB ; JsdB = HI%JsdB ; JedB = HI%JedB @@ -918,32 +920,26 @@ subroutine register_restarts_dyn_split_RK2(HI, GV, param_file, CS, restart_CS, u flux_units = get_flux_units(GV) if (GV%Boussinesq) then - vd = var_desc("sfc",thickness_units,"Free surface Height",'h','1') + vd(1) = var_desc("sfc",thickness_units,"Free surface Height",'h','1') else - vd = var_desc("p_bot",thickness_units,"Bottom Pressure",'h','1') + vd(1) = var_desc("p_bot",thickness_units,"Bottom Pressure",'h','1') endif - call register_restart_field(CS%eta, vd, .false., restart_CS) - - vd = var_desc("u2","m s-1","Auxiliary Zonal velocity",'u','L') - call register_restart_field(CS%u_av, vd, .false., restart_CS) - - vd = var_desc("v2","m s-1","Auxiliary Meridional velocity",'v','L') - call register_restart_field(CS%v_av, vd, .false., restart_CS) - - vd = var_desc("h2",thickness_units,"Auxiliary Layer Thickness",'h','L') - call register_restart_field(CS%h_av, vd, .false., restart_CS) + call register_restart_field(CS%eta, vd(1), .false., restart_CS) - vd = var_desc("uh",flux_units,"Zonal thickness flux",'u','L') - call register_restart_field(uh, vd, .false., restart_CS) + vd(1) = var_desc("u2","m s-1","Auxiliary Zonal velocity",'u','L') + vd(2) = var_desc("v2","m s-1","Auxiliary Meridional velocity",'v','L') + call register_restart_pair(CS%u_av, CS%v_av, vd(1), vd(2), .false., restart_CS) - vd = var_desc("vh",flux_units,"Meridional thickness flux",'v','L') - call register_restart_field(vh, vd, .false., restart_CS) + vd(1) = var_desc("h2",thickness_units,"Auxiliary Layer Thickness",'h','L') + call register_restart_field(CS%h_av, vd(1), .false., restart_CS) - vd = var_desc("diffu","m s-2","Zonal horizontal viscous acceleration",'u','L') - call register_restart_field(CS%diffu, vd, .false., restart_CS) + vd(1) = var_desc("uh",flux_units,"Zonal thickness flux",'u','L') + vd(2) = var_desc("vh",flux_units,"Meridional thickness flux",'v','L') + call register_restart_pair(uh, vh, vd(1), vd(2), .false., restart_CS) - vd = var_desc("diffv","m s-2","Meridional horizontal viscous acceleration",'v','L') - call register_restart_field(CS%diffv, vd, .false., restart_CS) + vd(1) = var_desc("diffu","m s-2","Zonal horizontal viscous acceleration",'u','L') + vd(2) = var_desc("diffv","m s-2","Meridional horizontal viscous acceleration",'v','L') + call register_restart_pair(CS%diffu, CS%diffv, vd(1), vd(2), .false., restart_CS) call register_barotropic_restarts(HI, GV, param_file, CS%barotropic_CSp, & restart_CS) diff --git a/src/core/MOM_forcing_type.F90 b/src/core/MOM_forcing_type.F90 index b7260c2da6..0a624b93e6 100644 --- a/src/core/MOM_forcing_type.F90 +++ b/src/core/MOM_forcing_type.F90 @@ -3,6 +3,7 @@ module MOM_forcing_type ! This file is part of MOM6. See LICENSE.md for the license. +use MOM_array_transform, only : rotate_array, rotate_vector, rotate_array_pair use MOM_debugging, only : hchksum, uvchksum 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, register_scalar_field @@ -35,6 +36,21 @@ module MOM_forcing_type public copy_common_forcing_fields, allocate_mech_forcing, deallocate_mech_forcing public set_derived_forcing_fields, copy_back_forcing_fields public set_net_mass_forcing, get_net_mass_forcing +public rotate_forcing, rotate_mech_forcing + +!> Allocate the fields of a (flux) forcing type, based on either a set of input +!! flags for each group of fields, or a pre-allocated reference forcing. +interface allocate_forcing_type + module procedure allocate_forcing_by_group + module procedure allocate_forcing_by_ref +end interface allocate_forcing_type + +!> Allocate the fields of a mechanical forcing type, based on either a set of +!! input flags for each group of fields, or a pre-allocated reference forcing. +interface allocate_mech_forcing + module procedure allocate_mech_forcing_by_group + module procedure allocate_mech_forcing_from_ref +end interface allocate_mech_forcing ! A note on unit descriptions in comments: MOM6 uses units that can be rescaled for dimensional ! consistency testing. These are noted in comments with units like Z, H, L, and T, along with @@ -2201,8 +2217,8 @@ end subroutine copy_back_forcing_fields !> Offer mechanical forcing fields for diagnostics for those !! fields registered as part of register_forcing_type_diags. -subroutine mech_forcing_diags(forces, dt, G, time_end, diag, handles) - type(mech_forcing), intent(in) :: forces !< A structure with the driving mechanical forces +subroutine mech_forcing_diags(forces_in, dt, G, time_end, diag, handles) + type(mech_forcing), target, intent(in) :: forces_in !< mechanical forcing input fields real, intent(in) :: dt !< time step for the forcing [s] type(ocean_grid_type), intent(in) :: G !< grid type type(time_type), intent(in) :: time_end !< The end time of the diagnostic interval. @@ -2211,8 +2227,22 @@ subroutine mech_forcing_diags(forces, dt, G, time_end, diag, handles) integer :: i,j,is,ie,js,je + type(mech_forcing), pointer :: forces + integer :: turns + call cpu_clock_begin(handles%id_clock_forcing) + ! NOTE: post_data expects data to be on the input index map, so any rotations + ! must be undone before saving the output. + turns = diag%G%HI%turns + if (turns /= 0) then + allocate(forces) + call allocate_mech_forcing(forces_in, diag%G, forces) + call rotate_mech_forcing(forces_in, turns, forces) + else + forces => forces_in + endif + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec call enable_averaging(dt, time_end, diag) ! if (query_averaging_enabled(diag)) then @@ -2232,34 +2262,56 @@ subroutine mech_forcing_diags(forces, dt, G, time_end, diag, handles) ! endif call disable_averaging(diag) + + if (turns /= 0) then + call deallocate_mech_forcing(forces) + deallocate(forces) + endif + call cpu_clock_end(handles%id_clock_forcing) 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, G, US, time_end, diag, handles) - type(forcing), intent(in) :: fluxes !< A structure containing thermodynamic forcing fields +subroutine forcing_diagnostics(fluxes_in, sfc_state, G_in, US, time_end, diag, handles) + type(forcing), target, intent(in) :: fluxes_in !< A structure containing thermodynamic forcing fields type(surface), intent(in) :: sfc_state !< A structure containing fields that !! describe the surface state of the ocean. - type(ocean_grid_type), intent(in) :: G !< grid type + type(ocean_grid_type), target, intent(in) :: G_in !< Input grid type type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(time_type), intent(in) :: time_end !< The end time of the diagnostic interval. type(diag_ctrl), intent(inout) :: diag !< diagnostic regulator type(forcing_diags), intent(inout) :: handles !< diagnostic ids ! local - real, dimension(SZI_(G),SZJ_(G)) :: res + type(ocean_grid_type), pointer :: G ! Grid metric on model index map + type(forcing), pointer :: fluxes ! Fluxes on the model index map + real, dimension(SZI_(diag%G),SZJ_(diag%G)) :: res real :: total_transport ! for diagnosing integrated boundary transport real :: ave_flux ! for diagnosing averaged boundary flux real :: C_p ! seawater heat capacity [J degC-1 kg-1] real :: RZ_T_conversion ! A combination of scaling factors for mass fluxes [kg T m-2 s-1 R-1 Z-1 ~> 1] real :: I_dt ! inverse time step [s-1] real :: ppt2mks ! conversion between ppt and mks + integer :: turns ! Number of index quarter turns integer :: i,j,is,ie,js,je call cpu_clock_begin(handles%id_clock_forcing) + ! NOTE: post_data expects data to be on the input index map, so any rotations + ! must be undone before saving the output. + turns = diag%G%HI%turns + if (turns /= 0) then + G => diag%G + allocate(fluxes) + call allocate_forcing_type(fluxes_in, G, fluxes) + call rotate_forcing(fluxes_in, fluxes, turns) + else + G => G_in + fluxes => fluxes_in + endif + C_p = US%Q_to_J_kg*fluxes%C_p RZ_T_conversion = US%RZ_T_to_kg_m2s I_dt = 1.0 / (US%T_to_s*fluxes%dt_buoy_accum) @@ -2806,12 +2858,18 @@ subroutine forcing_diagnostics(fluxes, sfc_state, G, US, time_end, diag, handles ! endif ! query_averaging_enabled call disable_averaging(diag) + if (turns /= 0) then + call deallocate_forcing_type(fluxes) + deallocate(fluxes) + endif + call cpu_clock_end(handles%id_clock_forcing) end subroutine forcing_diagnostics !> Conditionally allocate fields within the forcing type -subroutine allocate_forcing_type(G, fluxes, water, heat, ustar, press, shelf, iceberg, salt, fix_accum_bug) +subroutine allocate_forcing_by_group(G, fluxes, water, heat, ustar, press, & + shelf, iceberg, salt, fix_accum_bug) type(ocean_grid_type), intent(in) :: G !< Ocean grid structure type(forcing), intent(inout) :: fluxes !< A structure containing thermodynamic forcing fields logical, optional, intent(in) :: water !< If present and true, allocate water fluxes @@ -2879,11 +2937,61 @@ subroutine allocate_forcing_type(G, fluxes, water, heat, ustar, press, shelf, ic call myAlloc(fluxes%mass_berg,isd,ied,jsd,jed, iceberg) if (present(fix_accum_bug)) fluxes%gustless_accum_bug = .not.fix_accum_bug +end subroutine allocate_forcing_by_group + -end subroutine allocate_forcing_type +subroutine allocate_forcing_by_ref(fluxes_ref, G, fluxes) + type(forcing), intent(in) :: fluxes_ref !< Reference fluxes + type(ocean_grid_type), intent(in) :: G !< Grid metric of target fluxes + type(forcing), intent(out) :: fluxes !< Target fluxes -!> Conditionally allocate fields within the mechanical forcing type -subroutine allocate_mech_forcing(G, forces, stress, ustar, shelf, press, iceberg) + logical :: do_ustar, do_water, do_heat, do_salt, do_press, do_shelf, & + do_iceberg, do_heat_added, do_buoy + + call get_forcing_groups(fluxes_ref, do_water, do_heat, do_ustar, do_press, & + do_shelf, do_iceberg, do_salt, do_heat_added, do_buoy) + + call allocate_forcing_type(G, fluxes, do_water, do_heat, do_ustar, & + do_press, do_shelf, do_iceberg, do_salt) + + ! The following fluxes would typically be allocated by the driver + call myAlloc(fluxes%sw_vis_dir, G%isd, G%ied, G%jsd, G%jed, & + associated(fluxes_ref%sw_vis_dir)) + call myAlloc(fluxes%sw_vis_dif, G%isd, G%ied, G%jsd, G%jed, & + associated(fluxes_ref%sw_vis_dif)) + call myAlloc(fluxes%sw_nir_dir, G%isd, G%ied, G%jsd, G%jed, & + associated(fluxes_ref%sw_nir_dir)) + call myAlloc(fluxes%sw_nir_dif, G%isd, G%ied, G%jsd, G%jed, & + associated(fluxes_ref%sw_nir_dif)) + + call myAlloc(fluxes%salt_flux_in, G%isd, G%ied, G%jsd, G%jed, & + associated(fluxes_ref%salt_flux_in)) + call myAlloc(fluxes%salt_flux_added, G%isd, G%ied, G%jsd, G%jed, & + associated(fluxes_ref%salt_flux_added)) + + call myAlloc(fluxes%p_surf_full, G%isd, G%ied, G%jsd, G%jed, & + associated(fluxes_ref%p_surf_full)) + + call myAlloc(fluxes%heat_added, G%isd, G%ied, G%jsd, G%jed, & + associated(fluxes_ref%heat_added)) + call myAlloc(fluxes%buoy, G%isd, G%ied, G%jsd, G%jed, & + associated(fluxes_ref%buoy)) + + call myAlloc(fluxes%TKE_tidal, G%isd, G%ied, G%jsd, G%jed, & + associated(fluxes_ref%TKE_tidal)) + call myAlloc(fluxes%ustar_tidal, G%isd, G%ied, G%jsd, G%jed, & + associated(fluxes_ref%ustar_tidal)) + + ! This flag would normally be set by a control flag in allocate_forcing_type. + ! Here we copy the flag from the reference forcing. + fluxes%gustless_accum_bug = fluxes_ref%gustless_accum_bug +end subroutine allocate_forcing_by_ref + + +!> Conditionally allocate fields within the mechanical forcing type using +!! control flags. +subroutine allocate_mech_forcing_by_group(G, forces, stress, ustar, shelf, & + press, iceberg) type(ocean_grid_type), intent(in) :: G !< Ocean grid structure type(mech_forcing), intent(inout) :: forces !< Forcing fields structure @@ -2917,8 +3025,82 @@ subroutine allocate_mech_forcing(G, forces, stress, ustar, shelf, press, iceberg !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_by_group + + +!> Conditionally allocate fields within the mechanical forcing type based on a +!! reference forcing. +subroutine allocate_mech_forcing_from_ref(forces_ref, G, forces) + type(mech_forcing), intent(in) :: forces_ref !< Reference forcing fields + type(ocean_grid_type), intent(in) :: G !< Grid metric of target forcing + type(mech_forcing), intent(out) :: forces !< Mechanical forcing fields + + logical :: do_stress, do_ustar, do_shelf, do_press, do_iceberg + + ! Identify the active fields in the reference forcing + call get_mech_forcing_groups(forces_ref, do_stress, do_ustar, do_shelf, & + do_press, do_iceberg) + + call allocate_mech_forcing(G, forces, do_stress, do_ustar, do_shelf, & + do_press, do_iceberg) +end subroutine allocate_mech_forcing_from_ref + + +!> Return flags indicating which groups of forcings are allocated +subroutine get_forcing_groups(fluxes, water, heat, ustar, press, shelf, & + iceberg, salt, heat_added, buoy) + type(forcing), intent(in) :: fluxes !< Reference flux fields + logical, intent(out) :: water !< True if fluxes contains water-based fluxes + logical, intent(out) :: heat !< True if fluxes contains heat-based fluxes + logical, intent(out) :: ustar !< True if fluxes contains ustar fluxes + logical, intent(out) :: press !< True if fluxes contains surface pressure + logical, intent(out) :: shelf !< True if fluxes contains ice shelf fields + logical, intent(out) :: iceberg !< True if fluxes contains iceberg fluxes + logical, intent(out) :: salt !< True if fluxes contains salt flux + logical, intent(out) :: heat_added !< True if fluxes contains explicit heat + logical, intent(out) :: buoy !< True if fluxes contains buoyancy fluxes + + ! NOTE: heat, salt, heat_added, and buoy would typically depend on each other + ! to some degree. But since this would be enforced at the driver level, + ! we handle them here as independent flags. + + ustar = associated(fluxes%ustar) & + .and. associated(fluxes%ustar_gustless) + ! TODO: Check for all associated fields, but for now just check one as a marker + water = associated(fluxes%evap) + heat = associated(fluxes%seaice_melt_heat) + salt = associated(fluxes%salt_flux) + press = associated(fluxes%p_surf) + shelf = associated(fluxes%frac_shelf_h) + iceberg = associated(fluxes%ustar_berg) + heat_added = associated(fluxes%heat_added) + buoy = associated(fluxes%buoy) +end subroutine get_forcing_groups + + +!> Return flags indicating which groups of mechanical forcings are allocated +subroutine get_mech_forcing_groups(forces, stress, ustar, shelf, press, iceberg) + type(mech_forcing), intent(in) :: forces !< Reference forcing fields + logical, intent(out) :: stress !< True if forces contains wind stress fields + logical, intent(out) :: ustar !< True if forces contains ustar field + logical, intent(out) :: shelf !< True if forces contains ice shelf fields + logical, intent(out) :: press !< True if forces contains pressure fields + logical, intent(out) :: iceberg !< True if forces contains iceberg fields + + stress = associated(forces%taux) & + .and. associated(forces%tauy) + ustar = associated(forces%ustar) + shelf = associated(forces%rigidity_ice_u) & + .and. associated(forces%rigidity_ice_v) & + .and. associated(forces%frac_shelf_u) & + .and. associated(forces%frac_shelf_v) + press = associated(forces%p_surf) & + .and. associated(forces%p_surf_full) & + .and. associated(forces%net_mass_src) + iceberg = associated(forces%area_berg) & + .and. associated(forces%mass_berg) +end subroutine get_mech_forcing_groups -end subroutine allocate_mech_forcing !> Allocates and zeroes-out array. subroutine myAlloc(array, is, ie, js, je, flag) @@ -3006,6 +3188,181 @@ subroutine deallocate_mech_forcing(forces) end subroutine deallocate_mech_forcing +!< Rotate the fluxes by a set number of quarter turns +subroutine rotate_forcing(fluxes_in, fluxes, turns) + type(forcing), intent(in) :: fluxes_in !< Input forcing struct + type(forcing), intent(inout) :: fluxes !< Rotated forcing struct + integer, intent(in) :: turns !< Number of quarter turns + + logical :: do_ustar, do_water, do_heat, do_salt, do_press, do_shelf, & + do_iceberg, do_heat_added, do_buoy + + call get_forcing_groups(fluxes_in, do_water, do_heat, do_ustar, do_press, & + do_shelf, do_iceberg, do_salt, do_heat_added, do_buoy) + + if (do_ustar) then + call rotate_array(fluxes_in%ustar, turns, fluxes%ustar) + call rotate_array(fluxes_in%ustar_gustless, turns, fluxes%ustar_gustless) + endif + + if (do_water) then + call rotate_array(fluxes_in%evap, turns, fluxes%evap) + call rotate_array(fluxes_in%lprec, turns, fluxes%lprec) + call rotate_array(fluxes_in%fprec, turns, fluxes%fprec) + call rotate_array(fluxes_in%vprec, turns, fluxes%vprec) + call rotate_array(fluxes_in%lrunoff, turns, fluxes%lrunoff) + call rotate_array(fluxes_in%frunoff, turns, fluxes%frunoff) + call rotate_array(fluxes_in%seaice_melt, turns, fluxes%seaice_melt) + call rotate_array(fluxes_in%netMassOut, turns, fluxes%netMassOut) + call rotate_array(fluxes_in%netMassIn, turns, fluxes%netMassIn) + call rotate_array(fluxes_in%netSalt, turns, fluxes%netSalt) + endif + + if (do_heat) then + call rotate_array(fluxes_in%seaice_melt_heat, turns, fluxes%seaice_melt_heat) + call rotate_array(fluxes_in%sw, turns, fluxes%sw) + call rotate_array(fluxes_in%lw, turns, fluxes%lw) + call rotate_array(fluxes_in%latent, turns, fluxes%latent) + call rotate_array(fluxes_in%sens, turns, fluxes%sens) + call rotate_array(fluxes_in%latent_evap_diag, turns, fluxes%latent_evap_diag) + call rotate_array(fluxes_in%latent_fprec_diag, turns, fluxes%latent_fprec_diag) + call rotate_array(fluxes_in%latent_frunoff_diag, turns, fluxes%latent_frunoff_diag) + endif + + if (do_salt) then + call rotate_array(fluxes_in%salt_flux, turns, fluxes%salt_flux) + endif + + if (do_heat .and. do_water) then + call rotate_array(fluxes_in%heat_content_cond, turns, fluxes%heat_content_cond) + call rotate_array(fluxes_in%heat_content_icemelt, turns, fluxes%heat_content_icemelt) + call rotate_array(fluxes_in%heat_content_lprec, turns, fluxes%heat_content_lprec) + call rotate_array(fluxes_in%heat_content_fprec, turns, fluxes%heat_content_fprec) + call rotate_array(fluxes_in%heat_content_vprec, turns, fluxes%heat_content_vprec) + call rotate_array(fluxes_in%heat_content_lrunoff, turns, fluxes%heat_content_lrunoff) + call rotate_array(fluxes_in%heat_content_frunoff, turns, fluxes%heat_content_frunoff) + call rotate_array(fluxes_in%heat_content_massout, turns, fluxes%heat_content_massout) + call rotate_array(fluxes_in%heat_content_massin, turns, fluxes%heat_content_massin) + endif + + if (do_press) then + call rotate_array(fluxes_in%p_surf, turns, fluxes%p_surf) + endif + + if (do_shelf) then + call rotate_array(fluxes_in%frac_shelf_h, turns, fluxes%frac_shelf_h) + call rotate_array(fluxes_in%ustar_shelf, turns, fluxes%ustar_shelf) + call rotate_array(fluxes_in%iceshelf_melt, turns, fluxes%iceshelf_melt) + endif + + if (do_iceberg) then + call rotate_array(fluxes_in%ustar_berg, turns, fluxes%ustar_berg) + call rotate_array(fluxes_in%area_berg, turns, fluxes%area_berg) + call rotate_array(fluxes_in%iceshelf_melt, turns, fluxes%iceshelf_melt) + endif + + if (do_heat_added) then + call rotate_array(fluxes_in%heat_added, turns, fluxes%heat_added) + endif + + ! The following fields are handled by drivers rather than control flags. + if (associated(fluxes_in%sw_vis_dir)) & + call rotate_array(fluxes_in%sw_vis_dir, turns, fluxes%sw_vis_dir) + if (associated(fluxes_in%sw_vis_dif)) & + call rotate_array(fluxes_in%sw_vis_dif, turns, fluxes%sw_vis_dif) + if (associated(fluxes_in%sw_nir_dir)) & + call rotate_array(fluxes_in%sw_nir_dir, turns, fluxes%sw_nir_dir) + if (associated(fluxes_in%sw_nir_dif)) & + call rotate_array(fluxes_in%sw_nir_dif, turns, fluxes%sw_nir_dif) + + if (associated(fluxes_in%salt_flux_in)) & + call rotate_array(fluxes_in%salt_flux_in, turns, fluxes%salt_flux_in) + if (associated(fluxes_in%salt_flux_added)) & + call rotate_array(fluxes_in%salt_flux_added, turns, fluxes%salt_flux_added) + + if (associated(fluxes_in%p_surf_full)) & + call rotate_array(fluxes_in%p_surf_full, turns, fluxes%p_surf_full) + + if (associated(fluxes_in%buoy)) & + call rotate_array(fluxes_in%buoy, turns, fluxes%buoy) + + if (associated(fluxes_in%TKE_tidal)) & + call rotate_array(fluxes_in%TKE_tidal, turns, fluxes%TKE_tidal) + if (associated(fluxes_in%ustar_tidal)) & + call rotate_array(fluxes_in%ustar_tidal, turns, fluxes%ustar_tidal) + + ! TODO: tracer flux rotation + if (coupler_type_initialized(fluxes%tr_fluxes)) & + call MOM_error(FATAL, "Rotation of tracer BC fluxes not yet implemented.") + + ! Scalars and flags + fluxes%accumulate_p_surf = fluxes_in%accumulate_p_surf + + fluxes%vPrecGlobalAdj = fluxes_in%vPrecGlobalAdj + fluxes%saltFluxGlobalAdj = fluxes_in%saltFluxGlobalAdj + fluxes%netFWGlobalAdj = fluxes_in%netFWGlobalAdj + fluxes%vPrecGlobalScl = fluxes_in%vPrecGlobalScl + fluxes%saltFluxGlobalScl = fluxes_in%saltFluxGlobalScl + fluxes%netFWGlobalScl = fluxes_in%netFWGlobalScl + + fluxes%fluxes_used = fluxes_in%fluxes_used + fluxes%dt_buoy_accum = fluxes_in%dt_buoy_accum + fluxes%C_p = fluxes_in%C_p + ! NOTE: gustless_accum_bug is set during allocation + + fluxes%num_msg = fluxes_in%num_msg + fluxes%max_msg = fluxes_in%max_msg +end subroutine rotate_forcing + +!< Rotate the forcing fields from the input domain +subroutine rotate_mech_forcing(forces_in, turns, forces) + type(mech_forcing), intent(in) :: forces_in !< Forcing on the input domain + integer, intent(in) :: turns !< Number of quarter-turns + type(mech_forcing), intent(inout) :: forces !< Forcing on the rotated domain + + logical :: do_stress, do_ustar, do_shelf, do_press, do_iceberg + + call get_mech_forcing_groups(forces_in, do_stress, do_ustar, do_shelf, & + do_press, do_iceberg) + + if (do_stress) & + call rotate_vector(forces_in%taux, forces_in%tauy, turns, & + forces%taux, forces%tauy) + + if (do_ustar) & + call rotate_array(forces_in%ustar, turns, forces%ustar) + + if (do_shelf) then + call rotate_array_pair( & + forces_in%rigidity_ice_u, forces_in%rigidity_ice_v, turns, & + forces%rigidity_ice_u, forces%rigidity_ice_v & + ) + call rotate_array_pair( & + forces_in%frac_shelf_u, forces_in%frac_shelf_v, turns, & + forces%frac_shelf_u, forces%frac_shelf_v & + ) + endif + + if (do_press) then + ! NOTE: p_surf_SSH either points to p_surf or p_surf_full + call rotate_array(forces_in%p_surf, turns, forces%p_surf) + call rotate_array(forces_in%p_surf_full, turns, forces%p_surf_full) + call rotate_array(forces_in%net_mass_src, turns, forces%net_mass_src) + endif + + if (do_iceberg) then + call rotate_array(forces_in%area_berg, turns, forces%area_berg) + call rotate_array(forces_in%mass_berg, turns, forces%mass_berg) + endif + + ! Copy fields + forces%dt_force_accum = forces_in%dt_force_accum + forces%net_mass_src_set = forces_in%net_mass_src_set + forces%accumulate_p_surf = forces_in%accumulate_p_surf + forces%accumulate_rigidity = forces_in%accumulate_rigidity + forces%initialized = forces_in%initialized +end subroutine rotate_mech_forcing + !> \namespace mom_forcing_type !! !! \section section_fluxes Boundary fluxes diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index 3b1559ab81..28e50f4be5 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -3,6 +3,8 @@ module MOM_open_boundary ! This file is part of MOM6. See LICENSE.md for the license. +use MOM_array_transform, only : rotate_array, rotate_array_pair +use MOM_array_transform, only : allocate_rotated_array use MOM_coms, only : sum_across_PEs use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end, CLOCK_ROUTINE use MOM_diag_mediator, only : diag_ctrl, time_type @@ -16,7 +18,8 @@ module MOM_open_boundary use MOM_io, only : EAST_FACE, NORTH_FACE use MOM_io, only : slasher, read_data, field_size, SINGLE_FILE use MOM_io, only : vardesc, query_vardesc, var_desc -use MOM_restart, only : register_restart_field, query_initialized, MOM_restart_CS +use MOM_restart, only : register_restart_field, register_restart_pair +use MOM_restart, only : query_initialized, 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_time_manager, only : time_type, time_type_to_real, operator(-) @@ -57,6 +60,8 @@ module MOM_open_boundary public open_boundary_register_restarts public update_segment_tracer_reservoirs public update_OBC_ramp +public rotate_OBC_config +public rotate_OBC_init integer, parameter, public :: OBC_NONE = 0 !< Indicates the use of no open boundary integer, parameter, public :: OBC_SIMPLE = 1 !< Indicates the use of a simple inflow open boundary @@ -74,11 +79,11 @@ module MOM_open_boundary integer :: fid !< handle from FMS associated with segment data on disk integer :: fid_dz !< handle from FMS associated with segment thicknesses on disk character(len=8) :: name !< a name identifier for the segment data - real, pointer, dimension(:,:,:) :: buffer_src=>NULL() !< buffer for segment data located at cell faces + real, dimension(:,:,:), allocatable :: buffer_src !< buffer for segment data located at cell faces !! and on the original vertical grid integer :: nk_src !< Number of vertical levels in the source data - real, dimension(:,:,:), pointer :: dz_src=>NULL() !< vertical grid cell spacing of the incoming segment - !! data, set in [Z ~> m] then scaled to [H ~> m or kg m-2] + real, dimension(:,:,:), allocatable :: dz_src !< vertical grid cell spacing of the incoming segment + !! data, set in [Z ~> m] then scaled to [H ~> m or kg m-2] real, dimension(:,:,:), pointer :: buffer_dst=>NULL() !< buffer src data remapped to the target vertical grid real, dimension(:,:), pointer :: bt_vel=>NULL() !< barotropic velocity [L T-1 ~> m s-1] real :: value !< constant value if fid is equal to -1 @@ -836,53 +841,116 @@ subroutine setup_segment_indices(G, seg, Is_obc, Ie_obc, Js_obc, Je_obc) integer, intent(in) :: Js_obc !< Q-point global j-index of start of segment integer, intent(in) :: Je_obc !< Q-point global j-index of end of segment ! Local variables - integer :: Isg,Ieg,Jsg,Jeg + integer :: IsgB, IegB, JsgB, JegB + integer :: isg, ieg, jsg, jeg ! Isg, Ieg will be I*_obc in global space - if (Ie_obc Ie_obc) then + ! Northern boundary + isg = IsgB + 1 + jsg = JsgB + ieg = IegB + jeg = JegB + endif + + if (Is_obc < Ie_obc) then + ! Southern boundary + isg = IsgB + 1 + jsg = JsgB + 1 + ieg = IegB + jeg = JegB + 1 + endif + + if (Js_obc < Je_obc) then + ! Eastern boundary + isg = IsgB + jsg = JsgB + 1 + ieg = IegB + jeg = JegB + endif + + if (Js_obc > Je_obc) then + ! Western boundary + isg = IsgB + 1 + jsg = JsgB + 1 + ieg = IegB + 1 + jeg = JegB endif ! Global space I*_obc but sorted - seg%HI%IsgB = Isg ; seg%HI%IegB = Ieg - seg%HI%isg = Isg+1 ; seg%HI%ieg = Ieg - seg%HI%JsgB = Jsg ; seg%HI%JegB = Jeg - seg%HI%jsg = Jsg+1 ; seg%HI%Jeg = Jeg + seg%HI%IsgB = IsgB + seg%HI%JegB = JegB + seg%HI%IegB = IegB + seg%HI%JsgB = JsgB + + seg%HI%isg = isg + seg%HI%jsg = jsg + seg%HI%ieg = ieg + seg%HI%jeg = jeg ! Move into local index space - Isg = Isg - G%idg_offset - Jsg = Jsg - G%jdg_offset - Ieg = Ieg - G%idg_offset - Jeg = Jeg - G%jdg_offset + IsgB = IsgB - G%idg_offset + JsgB = JsgB - G%jdg_offset + IegB = IegB - G%idg_offset + JegB = JegB - G%jdg_offset + + isg = isg - G%idg_offset + jsg = jsg - G%jdg_offset + ieg = ieg - G%idg_offset + jeg = jeg - G%jdg_offset ! This is the i-extent of the segment on this PE. ! The values are nonsense if the segment is not on this PE. - seg%HI%IsdB = min( max(Isg, G%HI%IsdB), G%HI%IedB) - seg%HI%IedB = min( max(Ieg, G%HI%IsdB), G%HI%IedB) - seg%HI%isd = min( max(Isg+1, G%HI%isd), G%HI%ied) - seg%HI%ied = min( max(Ieg, G%HI%isd), G%HI%ied) - seg%HI%IscB = min( max(Isg, G%HI%IscB), G%HI%IecB) - seg%HI%IecB = min( max(Ieg, G%HI%IscB), G%HI%IecB) - seg%HI%isc = min( max(Isg+1, G%HI%isc), G%HI%iec) - seg%HI%iec = min( max(Ieg, G%HI%isc), G%HI%iec) + seg%HI%IsdB = min(max(IsgB, G%HI%IsdB), G%HI%IedB) + seg%HI%IedB = min(max(IegB, G%HI%IsdB), G%HI%IedB) + seg%HI%isd = min(max(isg, G%HI%isd), G%HI%ied) + seg%HI%ied = min(max(ieg, G%HI%isd), G%HI%ied) + seg%HI%IscB = min(max(IsgB, G%HI%IscB), G%HI%IecB) + seg%HI%IecB = min(max(IegB, G%HI%IscB), G%HI%IecB) + seg%HI%isc = min(max(isg, G%HI%isc), G%HI%iec) + seg%HI%iec = min(max(ieg, G%HI%isc), G%HI%iec) ! This is the j-extent of the segment on this PE. ! The values are nonsense if the segment is not on this PE. - seg%HI%JsdB = min( max(Jsg, G%HI%JsdB), G%HI%JedB) - seg%HI%JedB = min( max(Jeg, G%HI%JsdB), G%HI%JedB) - seg%HI%jsd = min( max(Jsg+1, G%HI%jsd), G%HI%jed) - seg%HI%jed = min( max(Jeg, G%HI%jsd), G%HI%jed) - seg%HI%JscB = min( max(Jsg, G%HI%JscB), G%HI%JecB) - seg%HI%JecB = min( max(Jeg, G%HI%JscB), G%HI%JecB) - seg%HI%jsc = min( max(Jsg+1, G%HI%jsc), G%HI%jec) - seg%HI%jec = min( max(Jeg, G%HI%jsc), G%HI%jec) + seg%HI%JsdB = min(max(JsgB, G%HI%JsdB), G%HI%JedB) + seg%HI%JedB = min(max(JegB, G%HI%JsdB), G%HI%JedB) + seg%HI%jsd = min(max(jsg, G%HI%jsd), G%HI%jed) + seg%HI%jed = min(max(jeg, G%HI%jsd), G%HI%jed) + seg%HI%JscB = min(max(JsgB, G%HI%JscB), G%HI%JecB) + seg%HI%JecB = min(max(JegB, G%HI%JscB), G%HI%JecB) + seg%HI%jsc = min(max(jsg, G%HI%jsc), G%HI%jec) + seg%HI%jec = min(max(jeg, G%HI%jsc), G%HI%jec) end subroutine setup_segment_indices @@ -1787,7 +1855,7 @@ end subroutine open_boundary_impose_land_mask !> Make sure the OBC tracer reservoirs are initialized. subroutine setup_OBC_tracer_reservoirs(G, OBC) - type(ocean_grid_type), intent(inout) :: G !< Ocean grid structure + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure type(ocean_OBC_type), pointer :: OBC !< Open boundary control structure ! Local variables type(OBC_segment_type), pointer :: segment => NULL() @@ -3453,23 +3521,28 @@ subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) character(len=200) :: filename, OBC_file, inputdir ! Strings for file/path type(OBC_segment_type), pointer :: segment => NULL() integer, dimension(4) :: siz + real, dimension(:,:,:), pointer :: tmp_buffer_in => NULL() ! Unrotated input integer :: ni_seg, nj_seg ! number of src gridpoints along the segments + integer :: ni_buf, nj_buf ! Number of filled values in tmp_buffer integer :: i2, j2 ! indices for referencing local domain array integer :: is_obc, ie_obc, js_obc, je_obc ! segment indices within local domain integer :: ishift, jshift ! offsets for staggered locations real, dimension(:,:), 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 + real, dimension(:,:,:), allocatable, target :: tmp_buffer real, dimension(:), allocatable :: h_stack integer :: is_obc2, js_obc2 real :: net_H_src, net_H_int, scl_fac real, pointer, dimension(:,:) :: normal_trans_bt=>NULL() ! barotropic transport + integer :: turns ! Number of index quarter turns is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB nz=G%ke + turns = G%HI%turns + if (.not. associated(OBC)) return do n = 1, OBC%number_of_segments @@ -3477,6 +3550,7 @@ subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) if (.not. segment%on_pe) cycle ! continue to next segment if not in computational domain + ! NOTE: These are in segment%HI, but defined slightly differently ni_seg = segment%ie_obc-segment%is_obc+1 nj_seg = segment%je_obc-segment%js_obc+1 is_obc = max(segment%is_obc,isd-1) @@ -3580,6 +3654,7 @@ subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) segment%field(m)%buffer_dst(:,:,:)=0.0 endif ! read source data interpolated to the current model time + ! NOTE: buffer is sized for vertex points, but may be used for faces if (siz(1)==1) then if (OBC%brushcutter_mode) then allocate(tmp_buffer(1,nj_seg*2-1,segment%field(m)%nk_src)) ! segment data is currrently on supergrid @@ -3594,7 +3669,44 @@ subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) endif endif - call time_interp_external(segment%field(m)%fid,Time, tmp_buffer) + ! TODO: Since we conditionally rotate a subset of tmp_buffer_in after + ! reading the value, it is currently not possible to use the rotated + ! implementation of time_interp_external. + ! For now, we must explicitly allocate and rotate this array. + if (turns /= 0) then + if (modulo(turns, 2) /= 0) then + allocate(tmp_buffer_in(size(tmp_buffer, 2), size(tmp_buffer, 1), size(tmp_buffer, 3))) + else + allocate(tmp_buffer_in(size(tmp_buffer, 1), size(tmp_buffer, 2), size(tmp_buffer, 3))) + endif + else + tmp_buffer_in => tmp_buffer + endif + + call time_interp_external(segment%field(m)%fid,Time, tmp_buffer_in) + ! NOTE: Rotation of face-points require that we skip the final value + if (turns /= 0) then + ! TODO: This is hardcoded for 90 degrees, and needs to be generalized. + if (segment%is_E_or_W & + .and. .not. (segment%field(m)%name == 'V' .or. segment%field(m)%name == 'DVDX')) then + nj_buf = size(tmp_buffer, 2) - 1 + call rotate_array(tmp_buffer_in(:nj_buf,:,:), turns, tmp_buffer(:,:nj_buf,:)) + elseif (segment%is_N_or_S & + .and. .not. (segment%field(m)%name == 'U' .or. segment%field(m)%name == 'DUDY')) then + ni_buf = size(tmp_buffer, 1) - 1 + call rotate_array(tmp_buffer_in(:,:ni_buf,:), turns, tmp_buffer(:ni_buf,:,:)) + else + call rotate_array(tmp_buffer_in, turns, tmp_buffer) + endif + + ! TODO: This is hardcoded for 90 degrees, and needs to be generalized. + if (segment%field(m)%name == 'U' & + .or. segment%field(m)%name == 'DVDX' & + .or. segment%field(m)%name == 'DUDY') then + tmp_buffer(:,:,:) = -tmp_buffer(:,:,:) + endif + endif + if (OBC%brushcutter_mode) then if (segment%is_E_or_W) then if (segment%field(m)%name == 'V' .or. segment%field(m)%name == 'DVDX') then @@ -3629,7 +3741,21 @@ subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) endif endif if (segment%field(m)%nk_src > 1) then - call time_interp_external(segment%field(m)%fid_dz,Time, tmp_buffer) + call time_interp_external(segment%field(m)%fid_dz,Time, tmp_buffer_in) + if (turns /= 0) then + ! TODO: This is hardcoded for 90 degrees, and needs to be generalized. + if (segment%is_E_or_W & + .and. .not. (segment%field(m)%name == 'V' .or. segment%field(m)%name == 'DVDX')) then + nj_buf = size(tmp_buffer, 2) - 1 + call rotate_array(tmp_buffer_in(:nj_buf,:,:), turns, tmp_buffer(:,:nj_buf,:)) + elseif (segment%is_N_or_S & + .and. .not. (segment%field(m)%name == 'U' .or. segment%field(m)%name == 'DUDY')) then + ni_buf = size(tmp_buffer, 1) - 1 + call rotate_array(tmp_buffer_in(:,:ni_buf,:), turns, tmp_buffer(:ni_buf,:,:)) + else + call rotate_array(tmp_buffer_in, turns, tmp_buffer) + endif + endif if (OBC%brushcutter_mode) then if (segment%is_E_or_W) then if (segment%field(m)%name == 'V' .or. segment%field(m)%name == 'DVDX') then @@ -3763,6 +3889,8 @@ subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) segment%field(m)%buffer_dst(:,:,1) = segment%field(m)%buffer_src(:,:,1) ! initialize remap destination buffer endif deallocate(tmp_buffer) + if (turns /= 0) & + deallocate(tmp_buffer_in) else ! fid <= 0 (Uniform value) if (.not. associated(segment%field(m)%buffer_dst)) then if (segment%is_E_or_W) then @@ -4214,7 +4342,7 @@ subroutine register_temp_salt_segments(GV, OBC, tr_Reg, param_file) end subroutine register_temp_salt_segments subroutine fill_temp_salt_segments(G, OBC, tv) - type(ocean_grid_type), intent(inout) :: G !< Ocean grid structure + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure type(ocean_OBC_type), pointer :: OBC !< Open boundary structure type(thermo_var_ptrs), intent(inout) :: tv !< Thermodynamics structure @@ -4268,6 +4396,7 @@ subroutine fill_temp_salt_segments(G, OBC, tv) 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 + call setup_OBC_tracer_reservoirs(G, OBC) end subroutine fill_temp_salt_segments @@ -4513,7 +4642,7 @@ subroutine open_boundary_register_restarts(HI, GV, OBC, Reg, param_file, restart type(MOM_restart_CS), pointer :: restart_CSp !< Restart structure, data intent(inout) logical, intent(in) :: use_temperature !< If true, T and S are used ! Local variables - type(vardesc) :: vd + type(vardesc) :: vd(2) integer :: m, n character(len=100) :: mesg type(OBC_segment_type), pointer :: segment=>NULL() @@ -4537,27 +4666,31 @@ subroutine open_boundary_register_restarts(HI, GV, OBC, Reg, param_file, restart ! so much memory and disk space. *** if (OBC%radiation_BCs_exist_globally) then allocate(OBC%rx_normal(HI%isdB:HI%iedB,HI%jsd:HI%jed,GV%ke)) - OBC%rx_normal(:,:,:) = 0.0 - vd = var_desc("rx_normal", "m s-1", "Normal Phase Speed for EW radiation OBCs", 'u', 'L') - call register_restart_field(OBC%rx_normal, vd, .false., restart_CSp) allocate(OBC%ry_normal(HI%isd:HI%ied,HI%jsdB:HI%jedB,GV%ke)) + OBC%rx_normal(:,:,:) = 0.0 OBC%ry_normal(:,:,:) = 0.0 - vd = var_desc("ry_normal", "m s-1", "Normal Phase Speed for NS radiation OBCs", 'v', 'L') - call register_restart_field(OBC%ry_normal, vd, .false., restart_CSp) + + vd(1) = var_desc("rx_normal", "m s-1", "Normal Phase Speed for EW radiation OBCs", 'u', 'L') + vd(2) = var_desc("ry_normal", "m s-1", "Normal Phase Speed for NS radiation OBCs", 'v', 'L') + call register_restart_pair(OBC%rx_normal, OBC%ry_normal, vd(1), vd(2), & + .false., restart_CSp) endif + if (OBC%oblique_BCs_exist_globally) then allocate(OBC%rx_oblique(HI%isdB:HI%iedB,HI%jsd:HI%jed,GV%ke)) - OBC%rx_oblique(:,:,:) = 0.0 - vd = var_desc("rx_oblique", "m2 s-2", "Radiation Speed Squared for EW oblique OBCs", 'u', 'L') - call register_restart_field(OBC%rx_oblique, vd, .false., restart_CSp) allocate(OBC%ry_oblique(HI%isd:HI%ied,HI%jsdB:HI%jedB,GV%ke)) + OBC%rx_oblique(:,:,:) = 0.0 OBC%ry_oblique(:,:,:) = 0.0 - vd = var_desc("ry_oblique", "m2 s-2", "Radiation Speed Squared for NS oblique OBCs", 'v', 'L') - call register_restart_field(OBC%ry_oblique, vd, .false., restart_CSp) + + vd(1) = var_desc("rx_oblique", "m2 s-2", "Radiation Speed Squared for EW oblique OBCs", 'u', 'L') + vd(2) = var_desc("ry_oblique", "m2 s-2", "Radiation Speed Squared for NS oblique OBCs", 'v', 'L') + call register_restart_pair(OBC%rx_oblique, OBC%ry_oblique, vd(1), vd(2), & + .false., restart_CSp) + allocate(OBC%cff_normal(HI%IsdB:HI%IedB,HI%jsdB:HI%jedB,GV%ke)) OBC%cff_normal(:,:,:) = 0.0 - vd = var_desc("cff_normal", "m2 s-2", "denominator for oblique OBCs", 'q', 'L') - call register_restart_field(OBC%cff_normal, vd, .false., restart_CSp) + vd(1) = var_desc("cff_normal", "m2 s-2", "denominator for oblique OBCs", 'q', 'L') + call register_restart_field(OBC%cff_normal, vd(1), .false., restart_CSp) endif if (Reg%ntr == 0) return @@ -4583,9 +4716,15 @@ subroutine open_boundary_register_restarts(HI, GV, OBC, Reg, param_file, restart OBC%tres_x(:,:,:,:) = 0.0 do m=1,OBC%ntr if (OBC%tracer_x_reservoirs_used(m)) then - write(mesg,'("tres_x_",I3.3)') m - vd = var_desc(mesg,"Conc", "Tracer concentration for EW OBCs",'u','L') - call register_restart_field(OBC%tres_x(:,:,:,m), vd, .false., restart_CSp) + if (modulo(HI%turns, 2) /= 0) then + write(mesg,'("tres_y_",I3.3)') m + vd(1) = var_desc(mesg,"Conc", "Tracer concentration for NS OBCs",'v','L') + call register_restart_field(OBC%tres_x(:,:,:,m), vd(1), .false., restart_CSp) + else + write(mesg,'("tres_x_",I3.3)') m + vd(1) = var_desc(mesg,"Conc", "Tracer concentration for EW OBCs",'u','L') + call register_restart_field(OBC%tres_x(:,:,:,m), vd(1), .false., restart_CSp) + endif endif enddo endif @@ -4594,13 +4733,18 @@ subroutine open_boundary_register_restarts(HI, GV, OBC, Reg, param_file, restart OBC%tres_y(:,:,:,:) = 0.0 do m=1,OBC%ntr if (OBC%tracer_y_reservoirs_used(m)) then - write(mesg,'("tres_y_",I3.3)') m - vd = var_desc(mesg,"Conc", "Tracer concentration for NS OBCs",'v','L') - call register_restart_field(OBC%tres_y(:,:,:,m), vd, .false., restart_CSp) + if (modulo(HI%turns, 2) /= 0) then + write(mesg,'("tres_x_",I3.3)') m + vd(1) = var_desc(mesg,"Conc", "Tracer concentration for EW OBCs",'u','L') + call register_restart_field(OBC%tres_y(:,:,:,m), vd(1), .false., restart_CSp) + else + write(mesg,'("tres_y_",I3.3)') m + vd(1) = var_desc(mesg,"Conc", "Tracer concentration for NS OBCs",'v','L') + call register_restart_field(OBC%tres_y(:,:,:,m), vd(1), .false., restart_CSp) + endif endif enddo endif - end subroutine open_boundary_register_restarts !> Update the OBC tracer reservoirs after the tracers have been updated. @@ -4783,6 +4927,309 @@ subroutine adjustSegmentEtaToFitBathymetry(G, GV, US, segment,fld) end subroutine adjustSegmentEtaToFitBathymetry +!> This is more of a rotate initialization than an actual rotate +subroutine rotate_OBC_config(OBC_in, G_in, OBC, G, turns) + type(ocean_OBC_type), pointer, intent(in) :: OBC_in !< Input OBC + type(dyn_horgrid_type), intent(in) :: G_in !< Input grid metric + type(ocean_OBC_type), pointer, intent(inout) :: OBC !< Rotated OBC + type(dyn_horgrid_type), intent(in) :: G !< Rotated grid metric + integer, intent(in) :: turns !< Number of quarter turns + + integer :: l + + ! Scalar and logical transfer + OBC%number_of_segments = OBC_in%number_of_segments + OBC%g_Earth = OBC_in%g_Earth + OBC%ke = OBC_in%ke + OBC%user_BCs_set_globally = OBC_in%user_BCs_set_globally + + ! These are conditionally read and set if number_of_segments > 0 + OBC%zero_vorticity = OBC_in%zero_vorticity + OBC%freeslip_vorticity = OBC_in%freeslip_vorticity + OBC%computed_vorticity = OBC_in%computed_vorticity + OBC%specified_vorticity = OBC_in%specified_vorticity + OBC%zero_strain = OBC_in%zero_strain + OBC%freeslip_strain = OBC_in%freeslip_strain + OBC%computed_strain = OBC_in%computed_strain + OBC%specified_strain = OBC_in%specified_strain + OBC%zero_biharmonic = OBC_in%zero_biharmonic + OBC%silly_h = OBC_in%silly_h + OBC%silly_u = OBC_in%silly_u + + ! Segment rotation + allocate(OBC%segment(0:OBC%number_of_segments)) + do l = 0, OBC%number_of_segments + call rotate_OBC_segment_config(OBC_in%segment(l), G_in, OBC%segment(l), G, turns) + ! Data up to setup_[uv]_point_obc is needed for allocate_obc_segment_data! + call allocate_OBC_segment_data(OBC, OBC%segment(l)) + call rotate_OBC_segment_data(OBC_in%segment(l), OBC%segment(l), turns) + enddo + + ! The horizontal segment map + allocate(OBC%segnum_u(G%IsdB:G%IedB,G%jsd:G%jed)) + allocate(OBC%segnum_v(G%isd:G%ied,G%JsdB:G%JedB)) + call rotate_array_pair(OBC_in%segnum_u, OBC_in%segnum_v, turns, & + OBC%segnum_u, OBC%segnum_v) + + ! These are conditionally enabled during segment configuration + OBC%open_u_BCs_exist_globally = OBC_in%open_v_BCs_exist_globally + OBC%open_v_BCs_exist_globally = OBC_in%open_u_BCs_exist_globally + OBC%Flather_u_BCs_exist_globally = OBC_in%Flather_v_BCs_exist_globally + OBC%Flather_v_BCs_exist_globally = OBC_in%Flather_u_BCs_exist_globally + OBC%oblique_BCs_exist_globally = OBC_in%oblique_BCs_exist_globally + OBC%nudged_u_BCs_exist_globally = OBC_in%nudged_v_BCs_exist_globally + OBC%nudged_v_BCs_exist_globally = OBC_in%nudged_u_BCs_exist_globally + OBC%specified_u_BCs_exist_globally= OBC_in%specified_v_BCs_exist_globally + OBC%specified_v_BCs_exist_globally= OBC_in%specified_u_BCs_exist_globally + OBC%radiation_BCs_exist_globally = OBC_in%radiation_BCs_exist_globally + + ! These are set by initialize_segment_data + OBC%brushcutter_mode = OBC_in%brushcutter_mode + OBC%update_OBC = OBC_in%update_OBC + OBC%needs_IO_for_data = OBC_in%needs_IO_for_data + + OBC%ntr = OBC_in%ntr + + OBC%gamma_uv = OBC_in%gamma_uv + OBC%rx_max = OBC_in%rx_max + OBC%OBC_pe = OBC_in%OBC_pe + + ! remap_CS is set up by initialize_segment_data, so we copy the fields here. + allocate(OBC%remap_CS) + OBC%remap_CS = OBC_in%remap_CS + + ! TODO: The OBC registry seems to be a list of "registered" OBC types. + ! It does not appear to be used, so for now we skip this record. + !OBC%OBC_Reg => OBC_in%OBC_Reg +end subroutine rotate_OBC_config + +!> Rotate the OBC segment configuration data from the input to model index map. +subroutine rotate_OBC_segment_config(segment_in, G_in, segment, G, turns) + type(OBC_segment_type), intent(in) :: segment_in !< Input OBC segment + type(dyn_horgrid_type), intent(in) :: G_in !< Input grid metric + type(OBC_segment_type), intent(inout) :: segment !< Rotated OBC segment + type(dyn_horgrid_type), intent(in) :: G !< Rotated grid metric + integer, intent(in) :: turns !< Number of quarter turns + + ! Global segment indices + integer :: Is_obc_in, Ie_obc_in, Js_obc_in, Je_obc_in ! Input domain + integer :: Is_obc, Ie_obc, Js_obc, Je_obc ! Rotated domain + + ! NOTE: A "rotation" of the OBC segment string would allow us to use + ! setup_[uv]_point_obc to set up most of this. For now, we just copy/swap + ! flags and manually rotate the indices. + + ! This is set if the segment is in the local grid + segment%on_pe = segment_in%on_pe + + ! Transfer configuration flags + segment%Flather = segment_in%Flather + segment%radiation = segment_in%radiation + segment%radiation_tan = segment_in%radiation_tan + segment%radiation_grad = segment_in%radiation_grad + segment%oblique = segment_in%oblique + segment%oblique_tan = segment_in%oblique_tan + segment%oblique_grad = segment_in%oblique_grad + segment%nudged = segment_in%nudged + segment%nudged_tan = segment_in%nudged_tan + segment%nudged_grad = segment_in%nudged_grad + segment%specified = segment_in%specified + segment%specified_tan = segment_in%specified_tan + segment%specified_grad = segment_in%specified_grad + segment%open = segment_in%open + segment%gradient = segment_in%gradient + + ! NOTE: [uv]_values_needed are swapped + segment%u_values_needed = segment_in%v_values_needed + segment%v_values_needed = segment_in%u_values_needed + segment%z_values_needed = segment_in%z_values_needed + segment%g_values_needed = segment_in%g_values_needed + segment%t_values_needed = segment_in%t_values_needed + segment%s_values_needed = segment_in%s_values_needed + + segment%values_needed = segment_in%values_needed + + ! These are conditionally set if nudged + segment%Velocity_nudging_timescale_in = segment_in%Velocity_nudging_timescale_in + segment%Velocity_nudging_timescale_out= segment_in%Velocity_nudging_timescale_out + + ! Rotate segment indices + + ! Reverse engineer the input [IJ][se]_obc segment indices + ! NOTE: The values stored in the segment are always saved in ascending order, + ! e.g. (is < ie). In order to use setup_segment_indices, we reorder the + ! indices here to indicate face direction. + ! Segment indices are also indexed locally, so we remove the halo offset. + if (segment_in%direction == OBC_DIRECTION_N) then + Is_obc_in = segment_in%Ie_obc + G_in%idg_offset + Ie_obc_in = segment_in%Is_obc + G_in%idg_offset + else + Is_obc_in = segment_in%Is_obc + G_in%idg_offset + Ie_obc_in = segment_in%Ie_obc + G_in%idg_offset + endif + + if (segment_in%direction == OBC_DIRECTION_W) then + Js_obc_in = segment_in%Je_obc + G_in%jdg_offset + Je_obc_in = segment_in%Js_obc + G_in%jdg_offset + else + Js_obc_in = segment_in%Js_obc + G_in%jdg_offset + Je_obc_in = segment_in%Je_obc + G_in%jdg_offset + endif + + ! TODO: This is hardcoded for 90 degrees, and needs to be generalized. + Is_obc = G_in%jegB - Js_obc_in + Ie_obc = G_in%JegB - Je_obc_in + Js_obc = Is_obc_in + Je_obc = Ie_obc_in + + ! Orientation is based on the index ordering, [IJ][se]_obc are re-ordered + ! after the index is set. So we now need to restore the original order + + call setup_segment_indices(G, segment, Is_obc, Ie_obc, Js_obc, Je_obc) + + ! Re-order [IJ][se]_obc back to ascending, and remove the halo offset. + if (Is_obc > Ie_obc) then + segment%Is_obc = Ie_obc - G%idg_offset + segment%Ie_obc = Is_obc - G%idg_offset + else + segment%Is_obc = Is_obc - G%idg_offset + segment%Ie_obc = Ie_obc - G%idg_offset + endif + + if (Js_obc > Je_obc) then + segment%Js_obc = Je_obc - G%jdg_offset + segment%Je_obc = Js_obc - G%jdg_offset + else + segment%Js_obc = Js_obc - G%jdg_offset + segment%Je_obc = Je_obc - G%jdg_offset + endif + + ! Reconfigure the directional flags + ! TODO: This is hardcoded for 90 degrees, and needs to be generalized. + select case (segment_in%direction) + case (OBC_DIRECTION_N) + segment%direction = OBC_DIRECTION_W + segment%is_E_or_W_2 = segment_in%is_N_or_S + segment%is_E_or_W = segment_in%is_N_or_S .and. segment_in%on_pe + segment%is_N_or_S = .false. + case (OBC_DIRECTION_W) + segment%direction = OBC_DIRECTION_S + segment%is_N_or_S = segment_in%is_E_or_W + segment%is_E_or_W = .false. + segment%is_E_or_W_2 = .false. + case (OBC_DIRECTION_S) + segment%direction = OBC_DIRECTION_E + segment%is_E_or_W_2 = segment_in%is_N_or_S + segment%is_E_or_W = segment_in%is_N_or_S .and. segment_in%on_pe + segment%is_N_or_S = .false. + case (OBC_DIRECTION_E) + segment%direction = OBC_DIRECTION_N + segment%is_N_or_S = segment_in%is_E_or_W + segment%is_E_or_W = .false. + segment%is_E_or_W_2 = .false. + case (OBC_NONE) + segment%direction = OBC_NONE + end select + + ! These are conditionally set if Lscale_{in,out} are present + segment%Tr_InvLscale_in = segment_in%Tr_InvLscale_in + segment%Tr_InvLscale_out = segment_in%Tr_InvLscale_out +end subroutine rotate_OBC_segment_config + + +!> Initialize the segments and field-related data of a rotated OBC. +subroutine rotate_OBC_init(OBC_in, G, GV, US, param_file, tv, restart_CSp, OBC) + type(ocean_OBC_type), pointer, intent(in) :: OBC_in !< OBC on input map + type(ocean_grid_type), intent(in) :: G !< Rotated grid metric + type(verticalGrid_type), intent(in) :: GV !< Vertical grid + type(unit_scale_type), intent(in) :: US !< Unit scaling + type(param_file_type), intent(in) :: param_file !< Input parameters + type(thermo_var_ptrs), intent(inout) :: tv !< Tracer fields + type(MOM_restart_CS), pointer, intent(in) :: restart_CSp !< Restart CS + type(ocean_OBC_type), pointer, intent(inout) :: OBC !< Rotated OBC + + logical :: use_temperature + integer :: l + + call get_param(param_file, "MOM", "ENABLE_THERMODYNAMICS", use_temperature, & + "If true, Temperature and salinity are used as state "//& + "variables.", default=.true., do_not_log=.true.) + + do l = 0, OBC%number_of_segments + call rotate_OBC_segment_data(OBC_in%segment(l), OBC%segment(l), G%HI%turns) + enddo + + if (use_temperature) & + call fill_temp_salt_segments(G, OBC, tv) + + call open_boundary_init(G, GV, US, param_file, OBC, restart_CSp) +end subroutine rotate_OBC_init + + +!> Rotate an OBC segment's fields from the input to the model index map. +subroutine rotate_OBC_segment_data(segment_in, segment, turns) + type(OBC_segment_type), intent(in) :: segment_in + type(OBC_segment_type), intent(inout) :: segment + integer, intent(in) :: turns + + integer :: n + integer :: is, ie, js, je, nk + integer :: num_fields + + + num_fields = segment_in%num_fields + allocate(segment%field(num_fields)) + + segment%num_fields = segment_in%num_fields + do n = 1, num_fields + segment%field(n)%fid = segment_in%field(n)%fid + segment%field(n)%fid_dz = segment_in%field(n)%fid_dz + + if (modulo(turns, 2) /= 0) then + select case (segment_in%field(n)%name) + case ('U') + segment%field(n)%name = 'V' + case ('V') + segment%field(n)%name = 'U' + case ('DVDX') + segment%field(n)%name = 'DUDY' + case ('DUDY') + segment%field(n)%name = 'DVDX' + case default + segment%field(n)%name = segment_in%field(n)%name + end select + else + segment%field(n)%name = segment_in%field(n)%name + endif + + if (allocated(segment_in%field(n)%buffer_src)) then + call allocate_rotated_array(segment_in%field(n)%buffer_src, & + lbound(segment_in%field(n)%buffer_src), turns, & + segment%field(n)%buffer_src) + call rotate_array(segment_in%field(n)%buffer_src, turns, & + segment%field(n)%buffer_src) + endif + + segment%field(n)%nk_src = segment_in%field(n)%nk_src + + if (allocated(segment_in%field(n)%dz_src)) then + call allocate_rotated_array(segment_in%field(n)%dz_src, & + lbound(segment_in%field(n)%dz_src), turns, & + segment%field(n)%dz_src) + call rotate_array(segment_in%field(n)%dz_src, turns, & + segment%field(n)%dz_src) + endif + + segment%field(n)%buffer_dst => NULL() + segment%field(n)%bt_vel => NULL() + + segment%field(n)%value = segment_in%field(n)%value + enddo + + segment%temp_segment_data_exists = segment_in%temp_segment_data_exists + segment%salt_segment_data_exists = segment_in%salt_segment_data_exists +end subroutine rotate_OBC_segment_data + !> \namespace mom_open_boundary !! This module implements some aspects of internal open boundary !! conditions in MOM. diff --git a/src/core/MOM_transcribe_grid.F90 b/src/core/MOM_transcribe_grid.F90 index 045fc9261c..51d44c1041 100644 --- a/src/core/MOM_transcribe_grid.F90 +++ b/src/core/MOM_transcribe_grid.F90 @@ -4,6 +4,7 @@ module MOM_transcribe_grid ! This file is part of MOM6. See LICENSE.md for the license. +use MOM_array_transform, only: rotate_array, rotate_array_pair use MOM_domains, only : pass_var, pass_vector use MOM_domains, only : To_All, SCALAR_PAIR, CGRID_NE, AGRID, BGRID_NE, CORNER use MOM_dyn_horgrid, only : dyn_horgrid_type, set_derived_dyn_horgrid @@ -11,9 +12,10 @@ module MOM_transcribe_grid use MOM_grid, only : ocean_grid_type, set_derived_metrics use MOM_unit_scaling, only : unit_scale_type + implicit none ; private -public copy_dyngrid_to_MOM_grid, copy_MOM_grid_to_dyngrid +public copy_dyngrid_to_MOM_grid, copy_MOM_grid_to_dyngrid, rotate_dyngrid contains @@ -305,4 +307,92 @@ subroutine copy_MOM_grid_to_dyngrid(oG, dG, US) end subroutine copy_MOM_grid_to_dyngrid +subroutine rotate_dyngrid(G_in, G, US, turns) + type(dyn_horgrid_type), intent(in) :: G_in !< Common horizontal grid type + type(dyn_horgrid_type), intent(inout) :: G !< Ocean grid type + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + integer, intent(in) :: turns !< Number of quarter turns + + integer :: jsc, jec, jscB, jecB + integer :: qturn + + ! Center point + call rotate_array(G_in%geoLonT, turns, G%geoLonT) + call rotate_array(G_in%geoLatT, turns, G%geoLatT) + call rotate_array_pair(G_in%dxT, G_in%dyT, turns, G%dxT, G%dyT) + call rotate_array(G_in%areaT, turns, G%areaT) + call rotate_array(G_in%bathyT, turns, G%bathyT) + + call rotate_array_pair(G_in%df_dx, G_in%df_dy, turns, G%df_dx, G%df_dy) + call rotate_array(G_in%sin_rot, turns, G%sin_rot) + call rotate_array(G_in%cos_rot, turns, G%cos_rot) + call rotate_array(G_in%mask2dT, turns, G%mask2dT) + + ! Face point + call rotate_array_pair(G_in%geoLonCu, G_in%geoLonCv, turns, & + G%geoLonCu, G%geoLonCv) + call rotate_array_pair(G_in%geoLatCu, G_in%geoLatCv, turns, & + G%geoLatCu, G%geoLatCv) + call rotate_array_pair(G_in%dxCu, G_in%dyCv, turns, G%dxCu, G%dyCv) + call rotate_array_pair(G_in%dxCv, G_in%dyCu, turns, G%dxCv, G%dyCu) + call rotate_array_pair(G_in%dx_Cv, G_in%dy_Cu, turns, G%dx_Cv, G%dy_Cu) + + call rotate_array_pair(G_in%mask2dCu, G_in%mask2dCv, turns, & + G%mask2dCu, G%mask2dCv) + call rotate_array_pair(G_in%areaCu, G_in%areaCv, turns, & + G%areaCu, G%areaCv) + call rotate_array_pair(G_in%IareaCu, G_in%IareaCv, turns, & + G%IareaCu, G%IareaCv) + + ! Vertex point + call rotate_array(G_in%geoLonBu, turns, G%geoLonBu) + call rotate_array(G_in%geoLatBu, turns, G%geoLatBu) + call rotate_array_pair(G_in%dxBu, G_in%dyBu, turns, G%dxBu, G%dyBu) + call rotate_array(G_in%areaBu, turns, G%areaBu) + call rotate_array(G_in%CoriolisBu, turns, G%CoriolisBu) + call rotate_array(G_in%mask2dBu, turns, G%mask2dBu) + + ! Topographic + G%bathymetry_at_vel = G_in%bathymetry_at_vel + if (G%bathymetry_at_vel) then + call rotate_array_pair(G_in%Dblock_u, G_in%Dblock_v, turns, & + G%Dblock_u, G%Dblock_v) + call rotate_array_pair(G_in%Dopen_u, G_in%Dopen_v, turns, & + G%Dopen_u, G%Dopen_v) + endif + + ! Nominal grid axes + ! TODO: We should not assign lat values to the lon axis, and vice versa. + ! We temporarily copy lat <-> lon since several components still expect + ! lat and lon sizes to match the first and second dimension sizes. + ! But we ought to instead leave them unchanged and adjust the references to + ! these axes. + if (modulo(turns, 2) /= 0) then + G%gridLonT(:) = G_in%gridLatT(G_in%jeg:G_in%jsg:-1) + G%gridLatT(:) = G_in%gridLonT(:) + G%gridLonB(:) = G_in%gridLatB(G_in%jeg:(G_in%jsg-1):-1) + G%gridLatB(:) = G_in%gridLonB(:) + else + G%gridLonT(:) = G_in%gridLonT(:) + G%gridLatT(:) = G_in%gridLatT(:) + G%gridLonB(:) = G_in%gridLonB(:) + G%gridLatB(:) = G_in%gridLatB(:) + endif + + G%x_axis_units = G_in%y_axis_units + G%y_axis_units = G_in%x_axis_units + G%south_lat = G_in%south_lat + G%west_lon = G_in%west_lon + G%len_lat = G_in%len_lat + G%len_lon = G_in%len_lon + + ! Rotation-invariant fields + G%areaT_global = G_in%areaT_global + G%IareaT_global = G_in%IareaT_global + G%Rad_Earth = G_in%Rad_Earth + G%max_depth = G_in%max_depth + + call set_derived_dyn_horgrid(G, US) +end subroutine rotate_dyngrid + end module MOM_transcribe_grid diff --git a/src/core/MOM_variables.F90 b/src/core/MOM_variables.F90 index 09cbd14c60..8e7dad1e51 100644 --- a/src/core/MOM_variables.F90 +++ b/src/core/MOM_variables.F90 @@ -3,6 +3,7 @@ module MOM_variables ! This file is part of MOM6. See LICENSE.md for the license. +use MOM_array_transform, only : rotate_array, rotate_vector use MOM_domains, only : MOM_domain_type, get_domain_extent, group_pass_type use MOM_debugging, only : hchksum use MOM_error_handler, only : MOM_error, FATAL @@ -11,6 +12,7 @@ module MOM_variables use coupler_types_mod, only : coupler_1d_bc_type, coupler_2d_bc_type use coupler_types_mod, only : coupler_type_spawn, coupler_type_destructor +use coupler_types_mod, only : coupler_type_initialized implicit none ; private @@ -18,6 +20,7 @@ module MOM_variables public allocate_surface_state, deallocate_surface_state, MOM_thermovar_chksum public ocean_grid_type, alloc_BT_cont_type, dealloc_BT_cont_type +public rotate_surface_state ! A note on unit descriptions in comments: MOM6 uses units that can be rescaled for dimensional ! consistency testing. These are noted in comments with units like Z, H, L, and T, along with @@ -395,6 +398,79 @@ subroutine deallocate_surface_state(sfc_state) end subroutine deallocate_surface_state +!> Rotate the surface state fields from the input to the model indices. +subroutine rotate_surface_state(sfc_state_in, G_in, sfc_state, G, turns) + type(surface), intent(in) :: sfc_state_in + type(ocean_grid_type), intent(in) :: G_in + type(surface), intent(inout) :: sfc_state + type(ocean_grid_type), intent(in) :: G + integer, intent(in) :: turns + + logical :: use_temperature, do_integrals, use_melt_potential, use_iceshelves + + ! NOTE: Many of these are weak tests, since only one is checked + use_temperature = allocated(sfc_state_in%SST) & + .and. allocated(sfc_state_in%SSS) + use_melt_potential = allocated(sfc_state_in%melt_potential) + do_integrals = allocated(sfc_state_in%ocean_mass) + use_iceshelves = allocated(sfc_state_in%taux_shelf) & + .and. allocated(sfc_state_in%tauy_shelf) + + if (.not. sfc_state%arrays_allocated) then + call allocate_surface_state(sfc_state, G, & + use_temperature=use_temperature, & + do_integrals=do_integrals, & + use_meltpot=use_melt_potential, & + use_iceshelves=use_iceshelves & + ) + sfc_state%arrays_allocated = .true. + endif + + if (use_temperature) then + call rotate_array(sfc_state_in%SST, turns, sfc_state%SST) + call rotate_array(sfc_state_in%SSS, turns, sfc_state%SSS) + else + call rotate_array(sfc_state_in%sfc_density, turns, sfc_state%sfc_density) + endif + + call rotate_array(sfc_state_in%Hml, turns, sfc_state%Hml) + call rotate_vector(sfc_state_in%u, sfc_state_in%v, turns, & + sfc_state%u, sfc_state%v) + call rotate_array(sfc_state_in%sea_lev, turns, sfc_state%sea_lev) + + if (use_melt_potential) then + call rotate_array(sfc_state_in%melt_potential, turns, sfc_state%melt_potential) + endif + + if (do_integrals) then + call rotate_array(sfc_state_in%ocean_mass, turns, sfc_state%ocean_mass) + if (use_temperature) then + call rotate_array(sfc_state_in%ocean_heat, turns, sfc_state%ocean_heat) + call rotate_array(sfc_state_in%ocean_salt, turns, sfc_state%ocean_salt) + call rotate_array(sfc_state_in%SSS, turns, sfc_state%TempxPmE) + call rotate_array(sfc_state_in%salt_deficit, turns, sfc_state%salt_deficit) + call rotate_array(sfc_state_in%internal_heat, turns, sfc_state%internal_heat) + endif + endif + + if (use_iceshelves) then + call rotate_vector(sfc_state_in%taux_shelf, sfc_state_in%tauy_shelf, turns, & + sfc_state%taux_shelf, sfc_state%tauy_shelf) + endif + + if (use_temperature .and. allocated(sfc_state_in%frazil)) & + call rotate_array(sfc_state_in%frazil, turns, sfc_state%frazil) + + ! Scalar transfers + sfc_state%T_is_conT = sfc_state_in%T_is_conT + sfc_state%S_is_absS = sfc_state_in%S_is_absS + + ! TODO: tracer field rotation + if (coupler_type_initialized(sfc_state_in%tr_fields)) & + call MOM_error(FATAL, "Rotation of surface state tracers is not yet " & + // "implemented.") +end subroutine rotate_surface_state + !> 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 !< The BT_cont_type whose elements will be allocated diff --git a/src/diagnostics/MOM_debugging.F90 b/src/diagnostics/MOM_debugging.F90 index d4d267d50d..611e6da2fc 100644 --- a/src/diagnostics/MOM_debugging.F90 +++ b/src/diagnostics/MOM_debugging.F90 @@ -8,7 +8,7 @@ module MOM_debugging ! This file is part of MOM6. See LICENSE.md for the license. -use MOM_checksums, only : hchksum, Bchksum, qchksum, uvchksum +use MOM_checksums, only : hchksum, Bchksum, qchksum, uvchksum, hchksum_pair use MOM_checksums, only : is_NaN, chksum, MOM_checksums_init use MOM_coms, only : PE_here, root_PE, num_PEs, sum_across_PEs use MOM_coms, only : min_across_PEs, max_across_PEs, reproducing_sum @@ -27,7 +27,7 @@ module MOM_debugging public :: check_column_integral, check_column_integrals ! These interfaces come from MOM_checksums. -public :: hchksum, Bchksum, qchksum, is_NaN, chksum, uvchksum +public :: hchksum, Bchksum, qchksum, is_NaN, chksum, uvchksum, hchksum_pair !> Check for consistency between the duplicated points of a C-grid vector interface check_redundant diff --git a/src/diagnostics/MOM_sum_output.F90 b/src/diagnostics/MOM_sum_output.F90 index 775cf39c22..de0f4eb8cd 100644 --- a/src/diagnostics/MOM_sum_output.F90 +++ b/src/diagnostics/MOM_sum_output.F90 @@ -376,6 +376,7 @@ subroutine write_energy(u, v, h, tv, day, n, G, GV, US, CS, tracer_CSp, OBC, dt_ mass_EFP, & ! Extended fixed point sums of total mass, etc. salt_EFP, heat_EFP, salt_chg_EFP, heat_chg_EFP, mass_chg_EFP, & mass_anom_EFP, salt_anom_EFP, heat_anom_EFP + real :: CFL_Iarea ! Direction-based inverse area used in CFL test [L-2]. real :: CFL_trans ! A transport-based definition of the CFL number [nondim]. real :: CFL_lin ! A simpler definition of the CFL number [nondim]. real :: max_CFL(2) ! The maxima of the CFL numbers [nondim]. @@ -719,21 +720,21 @@ subroutine write_energy(u, v, h, tv, day, n, G, GV, US, CS, tracer_CSp, OBC, dt_ ! Calculate the maximum CFL numbers. max_CFL(1:2) = 0.0 do k=1,nz ; do j=js,je ; do I=Isq,Ieq - if (u(I,j,k) < 0.0) then - CFL_trans = (-u(I,j,k) * CS%dt_in_T) * (G%dy_Cu(I,j) * G%IareaT(i+1,j)) - else - CFL_trans = (u(I,j,k) * CS%dt_in_T) * (G%dy_Cu(I,j) * G%IareaT(i,j)) - endif + CFL_Iarea = G%IareaT(i,j) + if (u(I,j,k) < 0.0) & + CFL_Iarea = G%IareaT(i+1,j) + + CFL_trans = abs(u(I,j,k) * CS%dt_in_T) * (G%dy_Cu(I,j) * CFL_Iarea) CFL_lin = abs(u(I,j,k) * CS%dt_in_T) * G%IdxCu(I,j) max_CFL(1) = max(max_CFL(1), CFL_trans) max_CFL(2) = max(max_CFL(2), CFL_lin) enddo ; enddo ; enddo do k=1,nz ; do J=Jsq,Jeq ; do i=is,ie - if (v(i,J,k) < 0.0) then - CFL_trans = (-v(i,J,k) * CS%dt_in_T) * (G%dx_Cv(i,J) * G%IareaT(i,j+1)) - else - CFL_trans = (v(i,J,k) * CS%dt_in_T) * (G%dx_Cv(i,J) * G%IareaT(i,j)) - endif + CFL_Iarea = G%IareaT(i,j) + if (v(i,J,k) < 0.0) & + CFL_Iarea = G%IareaT(i,j+1) + + CFL_trans = abs(v(i,J,k) * CS%dt_in_T) * (G%dx_Cv(i,J) * CFL_Iarea) CFL_lin = abs(v(i,J,k) * CS%dt_in_T) * G%IdyCv(i,J) max_CFL(1) = max(max_CFL(1), CFL_trans) max_CFL(2) = max(max_CFL(2), CFL_lin) diff --git a/src/framework/MOM_array_transform.F90 b/src/framework/MOM_array_transform.F90 new file mode 100644 index 0000000000..09d55ad50b --- /dev/null +++ b/src/framework/MOM_array_transform.F90 @@ -0,0 +1,358 @@ +!> Module for supporting the rotation of a field's index map. +!! The implementation of each angle is described below. +!! +!! +90deg: B(i,j) = A(n-j,i) +!! = transpose, then row reverse +!! 180deg: B(i,j) = A(m-i,n-j) +!! = row reversal + column reversal +!! -90deg: B(i,j) = A(j,m-i) +!! = row reverse, then transpose +!! +!! 90 degree rotations change the shape of the field, and are handled +!! separately from 180 degree rotations. + +module MOM_array_transform + +implicit none + +private +public rotate_array +public rotate_array_pair +public rotate_vector +public allocate_rotated_array + + +!> Rotate the elements of an array to the rotated set of indices. +!! Rotation is applied across the first and second axes of the array. +interface rotate_array + module procedure rotate_array_real_2d + module procedure rotate_array_real_3d + module procedure rotate_array_real_4d + module procedure rotate_array_integer + module procedure rotate_array_logical +end interface rotate_array + + +!> Rotate a pair of arrays which map to a rotated set of indices. +!! Rotation is applied across the first and second axes of the array. +!! This rotation should be applied when one field is mapped onto the other. +!! For example, a tracer indexed along u or v face points will map from one +!! to the other after a quarter turn, and back onto itself after a half turn. +interface rotate_array_pair + module procedure rotate_array_pair_real_2d + module procedure rotate_array_pair_real_3d + module procedure rotate_array_pair_integer +end interface rotate_array_pair + + +!> Rotate an array pair representing the components of a vector. +!! Rotation is applied across the first and second axes of the array. +!! This rotation should be applied when the fields satisfy vector +!! transformation rules. For example, the u and v components of a velocity +!! will map from one to the other for quarter turns, with a sign change in one +!! component. A half turn will map elements onto themselves with sign changes +!! in both components. +interface rotate_vector + module procedure rotate_vector_real_2d + module procedure rotate_vector_real_3d + module procedure rotate_vector_real_4d +end interface rotate_vector + + +!> Allocate an array based on the rotated index map of an unrotated reference +!! array. +interface allocate_rotated_array + module procedure allocate_rotated_array_real_2d + module procedure allocate_rotated_array_real_3d + module procedure allocate_rotated_array_real_4d + module procedure allocate_rotated_array_integer +end interface allocate_rotated_array + +contains + +!> Rotate the elements of a 2d real array along first and second axes. +subroutine rotate_array_real_2d(A_in, turns, A) + real, intent(in) :: A_in(:,:) !< Unrotated array + integer, intent(in) :: turns !< Number of quarter turns + real, intent(out) :: A(:,:) !< Rotated array + + integer :: m, n + + m = size(A_in, 1) + n = size(A_in, 2) + + select case (modulo(turns, 4)) + case(0) + A = A_in + case(1) + A = transpose(A_in) + A = A(n:1:-1, :) + case(2) + A = A_in(m:1:-1, n:1:-1) + case(3) + A = transpose(A_in(m:1:-1, :)) + end select +end subroutine rotate_array_real_2d + + +!> Rotate the elements of a 3d real array along first and second axes. +subroutine rotate_array_real_3d(A_in, turns, A) + real, intent(in) :: A_in(:,:,:) !< Unrotated array + integer, intent(in) :: turns !< Number of quarter turns + real, intent(out) :: A(:,:,:) !< Rotated array + + integer :: k + + do k = lbound(A_in, 3), ubound(A_in, 3) + call rotate_array(A_in(:,:,k), turns, A(:,:,k)) + enddo +end subroutine rotate_array_real_3d + + +!> Rotate the elements of a 4d real array along first and second axes. +subroutine rotate_array_real_4d(A_in, turns, A) + real, intent(in) :: A_in(:,:,:,:) !< Unrotated array + integer, intent(in) :: turns !< Number of quarter turns + real, intent(out) :: A(:,:,:,:) !< Rotated array + + integer :: n + + do n = lbound(A_in, 4), ubound(A_in, 4) + call rotate_array(A_in(:,:,:,n), turns, A(:,:,:,n)) + enddo +end subroutine rotate_array_real_4d + + +!> Rotate the elements of a 2d integer array along first and second axes. +subroutine rotate_array_integer(A_in, turns, A) + integer, intent(in) :: A_in(:,:) !< Unrotated array + integer, intent(in) :: turns !< Number of quarter turns + integer, intent(out) :: A(:,:) !< Rotated array + + integer :: m, n + + m = size(A_in, 1) + n = size(A_in, 2) + + select case (modulo(turns, 4)) + case(0) + A = A_in + case(1) + A = transpose(A_in) + A = A(n:1:-1, :) + case(2) + A = A_in(m:1:-1, n:1:-1) + case(3) + A = transpose(A_in(m:1:-1, :)) + end select +end subroutine rotate_array_integer + + +!> Rotate the elements of a 2d logical array along first and second axes. +subroutine rotate_array_logical(A_in, turns, A) + logical, intent(in) :: A_in(:,:) !< Unrotated array + integer, intent(in) :: turns !< Number of quarter turns + logical, intent(out) :: A(:,:) !< Rotated array + + integer :: m, n + + m = size(A_in, 1) + n = size(A_in, 2) + + select case (modulo(turns, 4)) + case(0) + A = A_in + case(1) + A = transpose(A_in) + A = A(n:1:-1, :) + case(2) + A = A_in(m:1:-1, n:1:-1) + case(3) + A = transpose(A_in(m:1:-1, :)) + end select +end subroutine rotate_array_logical + + +!> Rotate the elements of a 2d real array pair along first and second axes. +subroutine rotate_array_pair_real_2d(A_in, B_in, turns, A, B) + real, intent(in) :: A_in(:,:) !< Unrotated scalar array pair + real, intent(in) :: B_in(:,:) !< Unrotated scalar array pair + integer, intent(in) :: turns !< Number of quarter turns + real, intent(out) :: A(:,:) !< Rotated scalar array pair + real, intent(out) :: B(:,:) !< Rotated scalar array pair + + if (modulo(turns, 2) /= 0) then + call rotate_array(B_in, turns, A) + call rotate_array(A_in, turns, B) + else + call rotate_array(A_in, turns, A) + call rotate_array(B_in, turns, B) + endif +end subroutine rotate_array_pair_real_2d + + +!> Rotate the elements of a 3d real array pair along first and second axes. +subroutine rotate_array_pair_real_3d(A_in, B_in, turns, A, B) + real, intent(in) :: A_in(:,:,:) !< Unrotated scalar array pair + real, intent(in) :: B_in(:,:,:) !< Unrotated scalar array pair + integer, intent(in) :: turns !< Number of quarter turns + real, intent(out) :: A(:,:,:) !< Rotated scalar array pair + real, intent(out) :: B(:,:,:) !< Rotated scalar array pair + + integer :: k + + do k = lbound(A_in, 3), ubound(A_in, 3) + call rotate_array_pair(A_in(:,:,k), B_in(:,:,k), turns, & + A(:,:,k), B(:,:,k)) + enddo +end subroutine rotate_array_pair_real_3d + + +!> Rotate the elements of a 4d real array pair along first and second axes. +subroutine rotate_array_pair_integer(A_in, B_in, turns, A, B) + integer, intent(in) :: A_in(:,:) !< Unrotated scalar array pair + integer, intent(in) :: B_in(:,:) !< Unrotated scalar array pair + integer, intent(in) :: turns !< Number of quarter turns + integer, intent(out) :: A(:,:) !< Rotated scalar array pair + integer, intent(out) :: B(:,:) !< Rotated scalar array pair + + if (modulo(turns, 2) /= 0) then + call rotate_array(B_in, turns, A) + call rotate_array(A_in, turns, B) + else + call rotate_array(A_in, turns, A) + call rotate_array(B_in, turns, B) + endif +end subroutine rotate_array_pair_integer + + +!> Rotate the elements of a 2d real vector along first and second axes. +subroutine rotate_vector_real_2d(A_in, B_in, turns, A, B) + real, intent(in) :: A_in(:,:) !< First component of unrotated vector + real, intent(in) :: B_in(:,:) !< Second component of unrotated vector + integer, intent(in) :: turns !< Number of quarter turns + real, intent(out) :: A(:,:) !< First component of rotated vector + real, intent(out) :: B(:,:) !< Second component of unrotated vector + + call rotate_array_pair(A_in, B_in, turns, A, B) + + if (modulo(turns, 4) == 1 .or. modulo(turns, 4) == 2) & + A = -A + + if (modulo(turns, 4) == 2 .or. modulo(turns, 4) == 3) & + B = -B +end subroutine rotate_vector_real_2d + + +!> Rotate the elements of a 3d real vector along first and second axes. +subroutine rotate_vector_real_3d(A_in, B_in, turns, A, B) + real, intent(in) :: A_in(:,:,:) !< First component of unrotated vector + real, intent(in) :: B_in(:,:,:) !< Second component of unrotated vector + integer, intent(in) :: turns !< Number of quarter turns + real, intent(out) :: A(:,:,:) !< First component of rotated vector + real, intent(out) :: B(:,:,:) !< Second component of unrotated vector + + integer :: k + + do k = lbound(A_in, 3), ubound(A_in, 3) + call rotate_vector(A_in(:,:,k), B_in(:,:,k), turns, A(:,:,k), B(:,:,k)) + enddo +end subroutine rotate_vector_real_3d + + +!> Rotate the elements of a 4d real vector along first and second axes. +subroutine rotate_vector_real_4d(A_in, B_in, turns, A, B) + real, intent(in) :: A_in(:,:,:,:) !< First component of unrotated vector + real, intent(in) :: B_in(:,:,:,:) !< Second component of unrotated vector + integer, intent(in) :: turns !< Number of quarter turns + real, intent(out) :: A(:,:,:,:) !< First component of rotated vector + real, intent(out) :: B(:,:,:,:) !< Second component of unrotated vector + + integer :: n + + do n = lbound(A_in, 4), ubound(A_in, 4) + call rotate_vector(A_in(:,:,:,n), B_in(:,:,:,n), turns, & + A(:,:,:,n), B(:,:,:,n)) + enddo +end subroutine rotate_vector_real_4d + + +!> Allocate a 2d real array on the rotated index map of a reference array. +subroutine allocate_rotated_array_real_2d(A_in, lb, turns, A) + ! NOTE: lb must be declared before A_in + integer, intent(in) :: lb(2) !< Lower index bounds of A_in + real, intent(in) :: A_in(lb(1):, lb(2):) !< Reference array + integer, intent(in) :: turns !< Number of quarter turns + real, allocatable, intent(inout) :: A(:,:) !< Array on rotated index + + integer :: ub(2) + + ub(:) = ubound(A_in) + + if (modulo(turns, 2) /= 0) then + allocate(A(lb(2):ub(2), lb(1):ub(1))) + else + allocate(A(lb(1):ub(1), lb(2):ub(2))) + endif +end subroutine allocate_rotated_array_real_2d + + +!> Allocate a 3d real array on the rotated index map of a reference array. +subroutine allocate_rotated_array_real_3d(A_in, lb, turns, A) + ! NOTE: lb must be declared before A_in + integer, intent(in) :: lb(3) !< Lower index bounds of A_in + real, intent(in) :: A_in(lb(1):, lb(2):, lb(3):) !< Reference array + integer, intent(in) :: turns !< Number of quarter turns + real, allocatable, intent(inout) :: A(:,:,:) !< Array on rotated index + + integer :: ub(3) + + ub(:) = ubound(A_in) + + if (modulo(turns, 2) /= 0) then + allocate(A(lb(2):ub(2), lb(1):ub(1), lb(3):ub(3))) + else + allocate(A(lb(1):ub(1), lb(2):ub(2), lb(3):ub(3))) + endif +end subroutine allocate_rotated_array_real_3d + + +!> Allocate a 4d real array on the rotated index map of a reference array. +subroutine allocate_rotated_array_real_4d(A_in, lb, turns, A) + ! NOTE: lb must be declared before A_in + integer, intent(in) :: lb(4) !< Lower index bounds of A_in + real, intent(in) :: A_in(lb(1):,lb(2):,lb(3):,lb(4):) !< Reference array + integer, intent(in) :: turns !< Number of quarter turns + real, allocatable, intent(inout) :: A(:,:,:,:) !< Array on rotated index + + integer:: ub(4) + + ub(:) = ubound(A_in) + + if (modulo(turns, 2) /= 0) then + allocate(A(lb(2):ub(2), lb(1):ub(1), lb(3):ub(3), lb(4):ub(4))) + else + allocate(A(lb(1):ub(1), lb(2):ub(2), lb(3):ub(3), lb(4):ub(4))) + endif +end subroutine allocate_rotated_array_real_4d + + +!> Allocate a 2d integer array on the rotated index map of a reference array. +subroutine allocate_rotated_array_integer(A_in, lb, turns, A) + integer, intent(in) :: lb(2) !< Lower index bounds of A_in + integer, intent(in) :: A_in(lb(1):,lb(2):) !< Reference array + integer, intent(in) :: turns !< Number of quarter turns + integer, allocatable, intent(inout) :: A(:,:) !< Array on rotated index + + integer :: ub(2) + + ub(:) = ubound(A_in) + + if (modulo(turns, 2) /= 0) then + allocate(A(lb(2):ub(2), lb(1):ub(1))) + else + allocate(A(lb(1):ub(1), lb(2):ub(2))) + endif +end subroutine allocate_rotated_array_integer + +end module MOM_array_transform diff --git a/src/framework/MOM_checksums.F90 b/src/framework/MOM_checksums.F90 index ad269f3530..3cc1f316e2 100644 --- a/src/framework/MOM_checksums.F90 +++ b/src/framework/MOM_checksums.F90 @@ -3,12 +3,13 @@ module MOM_checksums ! This file is part of MOM6. See LICENSE.md for the license. +use MOM_array_transform, only: rotate_array, rotate_array_pair, rotate_vector use MOM_coms, only : PE_here, root_PE, num_PEs, sum_across_PEs use MOM_coms, only : min_across_PEs, max_across_PEs use MOM_coms, only : reproducing_sum use MOM_error_handler, only : MOM_error, FATAL, is_root_pe use MOM_file_parser, only : log_version, param_file_type -use MOM_hor_index, only : hor_index_type +use MOM_hor_index, only : hor_index_type, rotate_hor_index use iso_fortran_env, only: error_unit @@ -191,68 +192,126 @@ subroutine subStats(array, aMean, aMin, aMax) enddo aMean = sum(array(:)) / real(n) end subroutine subStats - end subroutine zchksum !> Checksums on a pair of 2d arrays staggered at tracer points. subroutine chksum_pair_h_2d(mesg, arrayA, arrayB, HI, haloshift, omit_corners, & - scale, logunit) + scale, logunit, scalar_pair) 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 !< The first array to be checksummed - real, dimension(HI%isd:,HI%jsd:), intent(in) :: arrayB !< The second array to be checksummed + type(hor_index_type), target, intent(in) :: HI !< A horizontal index type + real, dimension(HI%isd:,HI%jsd:), target, intent(in) :: arrayA !< The first array to be checksummed + real, dimension(HI%isd:,HI%jsd:), target, intent(in) :: arrayB !< The second array to be checksummed 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. integer, optional, intent(in) :: logunit !< IO unit for checksum logging + logical, optional, intent(in) :: scalar_pair !< If true, then the arrays describe + !! a scalar, rather than vector + logical :: vector_pair + integer :: turns + type(hor_index_type), pointer :: HI_in + real, dimension(:,:), pointer :: arrayA_in, arrayB_in + + vector_pair = .true. + if (present(scalar_pair)) vector_pair = .not. scalar_pair + + turns = HI%turns + if (modulo(turns, 4) /= 0) then + ! Rotate field back to the input grid + allocate(HI_in) + call rotate_hor_index(HI, -turns, HI_in) + allocate(arrayA_in(HI_in%isd:HI_in%ied, HI_in%jsd:HI_in%jed)) + allocate(arrayB_in(HI_in%isd:HI_in%ied, HI_in%jsd:HI_in%jed)) + + if (vector_pair) then + call rotate_vector(arrayA, arrayB, -turns, arrayA_in, arrayB_in) + else + call rotate_array_pair(arrayA, arrayB, -turns, arrayA_in, arrayB_in) + endif + else + HI_in => HI + arrayA_in => arrayA + arrayB_in => arrayB + endif if (present(haloshift)) then - call chksum_h_2d(arrayA, 'x '//mesg, HI, haloshift, omit_corners, & + call chksum_h_2d(arrayA_in, 'x '//mesg, HI_in, haloshift, omit_corners, & scale=scale, logunit=logunit) - call chksum_h_2d(arrayB, 'y '//mesg, HI, haloshift, omit_corners, & + call chksum_h_2d(arrayB_in, 'y '//mesg, HI_in, haloshift, omit_corners, & scale=scale, logunit=logunit) else - call chksum_h_2d(arrayA, 'x '//mesg, HI, scale=scale, logunit=logunit) - call chksum_h_2d(arrayB, 'y '//mesg, HI, scale=scale, logunit=logunit) + call chksum_h_2d(arrayA_in, 'x '//mesg, HI_in, scale=scale, logunit=logunit) + call chksum_h_2d(arrayB_in, 'y '//mesg, HI_in, scale=scale, logunit=logunit) endif - end subroutine chksum_pair_h_2d !> Checksums on a pair of 3d arrays staggered at tracer points. subroutine chksum_pair_h_3d(mesg, arrayA, arrayB, HI, haloshift, omit_corners, & - scale, logunit) + scale, logunit, scalar_pair) 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 !< The first array to be checksummed - real, dimension(HI%isd:,HI%jsd:, :), intent(in) :: arrayB !< The second array to be checksummed + type(hor_index_type), target, intent(in) :: HI !< A horizontal index type + real, dimension(HI%isd:,HI%jsd:, :), target, intent(in) :: arrayA !< The first array to be checksummed + real, dimension(HI%isd:,HI%jsd:, :), target, intent(in) :: arrayB !< The second array to be checksummed 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. integer, optional, intent(in) :: logunit !< IO unit for checksum logging + logical, optional, intent(in) :: scalar_pair !< If true, then the arrays describe + !! a scalar, rather than vector + logical :: vector_pair + integer :: turns + type(hor_index_type), pointer :: HI_in + real, dimension(:,:,:), pointer :: arrayA_in, arrayB_in + + vector_pair = .true. + if (present(scalar_pair)) vector_pair = .not. scalar_pair + + turns = HI%turns + if (modulo(turns, 4) /= 0) then + ! Rotate field back to the input grid + allocate(HI_in) + call rotate_hor_index(HI, -turns, HI_in) + allocate(arrayA_in(HI_in%isd:HI_in%ied, HI_in%jsd:HI_in%jed, size(arrayA, 3))) + allocate(arrayB_in(HI_in%isd:HI_in%ied, HI_in%jsd:HI_in%jed, size(arrayB, 3))) + + if (vector_pair) then + call rotate_vector(arrayA, arrayB, -turns, arrayA_in, arrayB_in) + else + call rotate_array_pair(arrayA, arrayB, -turns, arrayA_in, arrayB_in) + endif + else + HI_in => HI + arrayA_in => arrayA + arrayB_in => arrayB + endif + if (present(haloshift)) then - call chksum_h_3d(arrayA, 'x '//mesg, HI, haloshift, omit_corners, & + call chksum_h_3d(arrayA_in, 'x '//mesg, HI_in, haloshift, omit_corners, & scale=scale, logunit=logunit) - call chksum_h_3d(arrayB, 'y '//mesg, HI, haloshift, omit_corners, & + call chksum_h_3d(arrayB_in, 'y '//mesg, HI_in, haloshift, omit_corners, & scale=scale, logunit=logunit) else - call chksum_h_3d(arrayA, 'x '//mesg, HI, scale=scale, logunit=logunit) - call chksum_h_3d(arrayB, 'y '//mesg, HI, scale=scale, logunit=logunit) + call chksum_h_3d(arrayA_in, 'x '//mesg, HI_in, scale=scale, logunit=logunit) + call chksum_h_3d(arrayB_in, 'y '//mesg, HI_in, scale=scale, logunit=logunit) endif + ! NOTE: automatic deallocation of array[AB]_in end subroutine chksum_pair_h_3d !> Checksums a 2d array staggered at tracer points. -subroutine chksum_h_2d(array, mesg, HI, haloshift, omit_corners, scale, logunit) - 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 +subroutine chksum_h_2d(array_m, mesg, HI_m, haloshift, omit_corners, scale, logunit) + type(hor_index_type), target, intent(in) :: HI_m !< Horizontal index bounds of the model grid + real, dimension(HI_m%isd:,HI_m%jsd:), target, intent(in) :: array_m !< Field array on the model grid 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) :: omit_corners !< If true, avoid checking diagonal shifts real, optional, intent(in) :: scale !< A scaling factor for this array. integer, optional, intent(in) :: logunit !< IO unit for checksum logging + real, pointer :: array(:,:) ! Field array on the input grid real, allocatable, dimension(:,:) :: rescaled_array + type(hor_index_type), pointer :: HI ! Horizontal index bounds of the input grid real :: scaling integer :: iounit !< Log IO unit integer :: i, j @@ -260,6 +319,19 @@ subroutine chksum_h_2d(array, mesg, HI, haloshift, omit_corners, scale, logunit) integer :: bc0, bcSW, bcSE, bcNW, bcNE, hshift integer :: bcN, bcS, bcE, bcW logical :: do_corners + integer :: turns ! Quarter turns from input to model grid + + ! Rotate array to the input grid + turns = HI_m%turns + if (modulo(turns, 4) /= 0) then + allocate(HI) + call rotate_hor_index(HI_m, -turns, HI) + allocate(array(HI%isd:HI%ied, HI%jsd:HI%jed)) + call rotate_array(array_m, -turns, array) + else + HI => HI_m + array => array_m + endif if (checkForNaNs) then if (is_NaN(array(HI%isc:HI%iec,HI%jsc:HI%jec))) & @@ -373,31 +445,59 @@ end subroutine chksum_h_2d !> Checksums on a pair of 2d arrays staggered at q-points. subroutine chksum_pair_B_2d(mesg, arrayA, arrayB, HI, haloshift, symmetric, & - omit_corners, scale, logunit) + omit_corners, scale, logunit, scalar_pair) 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 !< The first array to be checksummed - real, dimension(HI%isd:,HI%jsd:), intent(in) :: arrayB !< The second array to be checksummed + type(hor_index_type), target, intent(in) :: HI !< A horizontal index type + real, dimension(HI%isd:,HI%jsd:), target, intent(in) :: arrayA !< The first array to be checksummed + real, dimension(HI%isd:,HI%jsd:), target, intent(in) :: arrayB !< The second array to be checksummed 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. integer, optional, intent(in) :: logunit !< IO unit for checksum logging + logical, optional, intent(in) :: scalar_pair !< If true, then the arrays describe + !! a scalar, rather than vector logical :: sym + logical :: vector_pair + integer :: turns + type(hor_index_type), pointer :: HI_in + real, dimension(:,:), pointer :: arrayA_in, arrayB_in + + vector_pair = .true. + if (present(scalar_pair)) vector_pair = .not. scalar_pair + + turns = HI%turns + if (modulo(turns, 4) /= 0) then + ! Rotate field back to the input grid + allocate(HI_in) + call rotate_hor_index(HI, -turns, HI_in) + allocate(arrayA_in(HI_in%IsdB:HI_in%IedB, HI_in%JsdB:HI_in%JedB)) + allocate(arrayB_in(HI_in%IsdB:HI_in%IedB, HI_in%JsdB:HI_in%JedB)) + + if (vector_pair) then + call rotate_vector(arrayA, arrayB, -turns, arrayA_in, arrayB_in) + else + call rotate_array_pair(arrayA, arrayB, -turns, arrayA_in, arrayB_in) + endif + else + HI_in => HI + arrayA_in => arrayA + arrayB_in => arrayB + endif sym = .false. ; if (present(symmetric)) sym = symmetric if (present(haloshift)) then - call chksum_B_2d(arrayA, 'x '//mesg, HI, haloshift, symmetric=sym, & + call chksum_B_2d(arrayA_in, 'x '//mesg, HI_in, haloshift, symmetric=sym, & omit_corners=omit_corners, scale=scale, logunit=logunit) - call chksum_B_2d(arrayB, 'y '//mesg, HI, haloshift, symmetric=sym, & + call chksum_B_2d(arrayB_in, 'y '//mesg, HI_in, haloshift, symmetric=sym, & omit_corners=omit_corners, scale=scale, logunit=logunit) else - call chksum_B_2d(arrayA, 'x '//mesg, HI, symmetric=sym, scale=scale, & + call chksum_B_2d(arrayA_in, 'x '//mesg, HI_in, symmetric=sym, scale=scale, & logunit=logunit) - call chksum_B_2d(arrayB, 'y '//mesg, HI, symmetric=sym, scale=scale, & + call chksum_B_2d(arrayB_in, 'y '//mesg, HI_in, symmetric=sym, scale=scale, & logunit=logunit) endif @@ -405,40 +505,67 @@ end subroutine chksum_pair_B_2d !> Checksums on a pair of 3d arrays staggered at q-points. subroutine chksum_pair_B_3d(mesg, arrayA, arrayB, HI, haloshift, symmetric, & - omit_corners, scale, logunit) + omit_corners, scale, logunit, scalar_pair) character(len=*), intent(in) :: mesg !< Identifying messages - type(hor_index_type), intent(in) :: HI !< A horizontal index type - real, dimension(HI%IsdB:,HI%JsdB:, :), intent(in) :: arrayA !< The first array to be checksummed - real, dimension(HI%IsdB:,HI%JsdB:, :), intent(in) :: arrayB !< The second array to be checksummed + type(hor_index_type), target, intent(in) :: HI !< A horizontal index type + real, dimension(HI%IsdB:,HI%JsdB:, :), target, intent(in) :: arrayA !< The first array to be checksummed + real, dimension(HI%IsdB:,HI%JsdB:, :), target, intent(in) :: arrayB !< The second 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) :: omit_corners !< If true, avoid checking diagonal shifts real, optional, intent(in) :: scale !< A scaling factor for this array. integer, optional, intent(in) :: logunit !< IO unit for checksum logging + logical, optional, intent(in) :: scalar_pair !< If true, then the arrays describe + !! a scalar, rather than vector logical :: sym + logical :: vector_pair + integer :: turns + type(hor_index_type), pointer :: HI_in + real, dimension(:,:,:), pointer :: arrayA_in, arrayB_in + + vector_pair = .true. + if (present(scalar_pair)) vector_pair = .not. scalar_pair + + turns = HI%turns + if (modulo(turns, 4) /= 0) then + ! Rotate field back to the input grid + allocate(HI_in) + call rotate_hor_index(HI, -turns, HI_in) + allocate(arrayA_in(HI_in%IsdB:HI_in%IedB, HI_in%JsdB:HI_in%JedB, size(arrayA, 3))) + allocate(arrayB_in(HI_in%IsdB:HI_in%IedB, HI_in%JsdB:HI_in%JedB, size(arrayB, 3))) + + if (vector_pair) then + call rotate_vector(arrayA, arrayB, -turns, arrayA_in, arrayB_in) + else + call rotate_array_pair(arrayA, arrayB, -turns, arrayA_in, arrayB_in) + endif + else + HI_in => HI + arrayA_in => arrayA + arrayB_in => arrayB + endif if (present(haloshift)) then - call chksum_B_3d(arrayA, 'x '//mesg, HI, haloshift, symmetric, & + call chksum_B_3d(arrayA_in, 'x '//mesg, HI_in, haloshift, symmetric, & omit_corners, scale=scale, logunit=logunit) - call chksum_B_3d(arrayB, 'y '//mesg, HI, haloshift, symmetric, & + call chksum_B_3d(arrayB_in, 'y '//mesg, HI_in, haloshift, symmetric, & omit_corners, scale=scale, logunit=logunit) else - call chksum_B_3d(arrayA, 'x '//mesg, HI, symmetric=symmetric, scale=scale, & + call chksum_B_3d(arrayA_in, 'x '//mesg, HI_in, symmetric=symmetric, scale=scale, & logunit=logunit) - call chksum_B_3d(arrayB, 'y '//mesg, HI, symmetric=symmetric, scale=scale, & + call chksum_B_3d(arrayB_in, 'y '//mesg, HI_in, symmetric=symmetric, scale=scale, & logunit=logunit) endif - end subroutine chksum_pair_B_3d !> Checksums a 2d array staggered at corner points. -subroutine chksum_B_2d(array, mesg, HI, haloshift, symmetric, omit_corners, & +subroutine chksum_B_2d(array_m, mesg, HI_m, haloshift, symmetric, omit_corners, & scale, logunit) - 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 + type(hor_index_type), target, intent(in) :: HI_m !< A horizontal index type + real, dimension(HI_m%IsdB:,HI_m%JsdB:), & + target, intent(in) :: array_m !< 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 @@ -447,7 +574,9 @@ subroutine chksum_B_2d(array, mesg, HI, haloshift, symmetric, omit_corners, & real, optional, intent(in) :: scale !< A scaling factor for this array. integer, optional, intent(in) :: logunit !< IO unit for checksum logging + real, pointer :: array(:,:) ! Field array on the input grid real, allocatable, dimension(:,:) :: rescaled_array + type(hor_index_type), pointer :: HI ! Horizontal index bounds of the input grid real :: scaling integer :: iounit !< Log IO unit integer :: i, j, Is, Js @@ -455,6 +584,19 @@ subroutine chksum_B_2d(array, mesg, HI, haloshift, symmetric, omit_corners, & integer :: bc0, bcSW, bcSE, bcNW, bcNE, hshift integer :: bcN, bcS, bcE, bcW logical :: do_corners, sym, sym_stats + integer :: turns ! Quarter turns from input to model grid + + ! Rotate array to the input grid + turns = HI_m%turns + if (modulo(turns, 4) /= 0) then + allocate(HI) + call rotate_hor_index(HI_m, -turns, HI) + allocate(array(HI%IsdB:HI%IedB, HI%JsdB:HI%JedB)) + call rotate_array(array_m, -turns, array) + else + HI => HI_m + array => array_m + endif if (checkForNaNs) then if (is_NaN(array(HI%IscB:HI%IecB,HI%JscB:HI%JecB))) & @@ -585,65 +727,119 @@ end subroutine chksum_B_2d !> Checksums a pair of 2d velocity arrays staggered at C-grid locations subroutine chksum_uv_2d(mesg, arrayU, arrayV, HI, haloshift, symmetric, & - omit_corners, scale, logunit) + omit_corners, scale, logunit, scalar_pair) character(len=*), intent(in) :: mesg !< Identifying messages - type(hor_index_type), intent(in) :: HI !< A horizontal index type - 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 + type(hor_index_type), target, intent(in) :: HI !< A horizontal index type + real, dimension(HI%IsdB:,HI%jsd:), target, intent(in) :: arrayU !< The u-component array to be checksummed + real, dimension(HI%isd:,HI%JsdB:), target, 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) :: omit_corners !< If true, avoid checking diagonal shifts real, optional, intent(in) :: scale !< A scaling factor for these arrays. integer, optional, intent(in) :: logunit !< IO unit for checksum logging + logical, optional, intent(in) :: scalar_pair !< If true, then the arrays describe a + !! a scalar, rather than vector + logical :: vector_pair + integer :: turns + type(hor_index_type), pointer :: HI_in + real, dimension(:,:), pointer :: arrayU_in, arrayV_in + + vector_pair = .true. + if (present(scalar_pair)) vector_pair = .not. scalar_pair + + turns = HI%turns + if (modulo(turns, 4) /= 0) then + ! Rotate field back to the input grid + allocate(HI_in) + call rotate_hor_index(HI, -turns, HI_in) + allocate(arrayU_in(HI_in%IsdB:HI_in%IedB, HI_in%jsd:HI_in%jed)) + allocate(arrayV_in(HI_in%isd:HI_in%ied, HI_in%JsdB:HI_in%JedB)) + + if (vector_pair) then + call rotate_vector(arrayU, arrayV, -turns, arrayU_in, arrayV_in) + else + call rotate_array_pair(arrayU, arrayV, -turns, arrayU_in, arrayV_in) + endif + else + HI_in => HI + arrayU_in => arrayU + arrayV_in => arrayV + endif if (present(haloshift)) then - call chksum_u_2d(arrayU, 'u '//mesg, HI, haloshift, symmetric, & - omit_corners, scale, logunit=logunit) - call chksum_v_2d(arrayV, 'v '//mesg, HI, haloshift, symmetric, & - omit_corners, scale, logunit=logunit) + call chksum_u_2d(arrayU_in, 'u '//mesg, HI_in, haloshift, symmetric, & + omit_corners, scale=scale, logunit=logunit) + call chksum_v_2d(arrayV_in, 'v '//mesg, HI_in, haloshift, symmetric, & + omit_corners, scale=scale, logunit=logunit) else - call chksum_u_2d(arrayU, 'u '//mesg, HI, symmetric=symmetric, & - logunit=logunit) - call chksum_v_2d(arrayV, 'v '//mesg, HI, symmetric=symmetric, & - logunit=logunit) + call chksum_u_2d(arrayU_in, 'u '//mesg, HI_in, symmetric=symmetric, & + scale=scale, logunit=logunit) + call chksum_v_2d(arrayV_in, 'v '//mesg, HI_in, symmetric=symmetric, & + scale=scale, logunit=logunit) endif - end subroutine chksum_uv_2d !> Checksums a pair of 3d velocity arrays staggered at C-grid locations subroutine chksum_uv_3d(mesg, arrayU, arrayV, HI, haloshift, symmetric, & - omit_corners, scale, logunit) + omit_corners, scale, logunit, scalar_pair) character(len=*), intent(in) :: mesg !< Identifying messages - type(hor_index_type), intent(in) :: HI !< A horizontal index type - 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 + type(hor_index_type), target, intent(in) :: HI !< A horizontal index type + real, dimension(HI%IsdB:,HI%jsd:,:), target, intent(in) :: arrayU !< The u-component array to be checksummed + real, dimension(HI%isd:,HI%JsdB:,:), target, 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) :: omit_corners !< If true, avoid checking diagonal shifts real, optional, intent(in) :: scale !< A scaling factor for these arrays. integer, optional, intent(in) :: logunit !< IO unit for checksum logging + logical, optional, intent(in) :: scalar_pair !< If true, then the arrays describe a + !! a scalar, rather than vector + logical :: vector_pair + integer :: turns + type(hor_index_type), pointer :: HI_in + real, dimension(:,:,:), pointer :: arrayU_in, arrayV_in + + vector_pair = .true. + if (present(scalar_pair)) vector_pair = .not. scalar_pair + + turns = HI%turns + if (modulo(turns, 4) /= 0) then + ! Rotate field back to the input grid + allocate(HI_in) + call rotate_hor_index(HI, -turns, HI_in) + allocate(arrayU_in(HI_in%IsdB:HI_in%IedB, HI_in%jsd:HI_in%jed, size(arrayU, 3))) + allocate(arrayV_in(HI_in%isd:HI_in%ied, HI_in%JsdB:HI_in%JedB, size(arrayV, 3))) + + if (vector_pair) then + call rotate_vector(arrayU, arrayV, -turns, arrayU_in, arrayV_in) + else + call rotate_array_pair(arrayU, arrayV, -turns, arrayU_in, arrayV_in) + endif + else + HI_in => HI + arrayU_in => arrayU + arrayV_in => arrayV + endif if (present(haloshift)) then - call chksum_u_3d(arrayU, 'u '//mesg, HI, haloshift, symmetric, & - omit_corners, scale, logunit=logunit) - call chksum_v_3d(arrayV, 'v '//mesg, HI, haloshift, symmetric, & - omit_corners, scale, logunit=logunit) + call chksum_u_3d(arrayU_in, 'u '//mesg, HI_in, haloshift, symmetric, & + omit_corners, scale=scale, logunit=logunit) + call chksum_v_3d(arrayV_in, 'v '//mesg, HI_in, haloshift, symmetric, & + omit_corners, scale=scale, logunit=logunit) else - call chksum_u_3d(arrayU, 'u '//mesg, HI, symmetric=symmetric, & - logunit=logunit) - call chksum_v_3d(arrayV, 'v '//mesg, HI, symmetric=symmetric, & - logunit=logunit) + call chksum_u_3d(arrayU_in, 'u '//mesg, HI_in, symmetric=symmetric, & + scale=scale, logunit=logunit) + call chksum_v_3d(arrayV_in, 'v '//mesg, HI_in, symmetric=symmetric, & + scale=scale, logunit=logunit) endif - end subroutine chksum_uv_3d !> Checksums a 2d array staggered at C-grid u points. -subroutine chksum_u_2d(array, mesg, HI, haloshift, symmetric, omit_corners, & +subroutine chksum_u_2d(array_m, mesg, HI_m, haloshift, symmetric, omit_corners, & scale, logunit) - 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 + type(hor_index_type), target, intent(in) :: HI_m !< A horizontal index type + real, dimension(HI_m%IsdB:,HI_m%jsd:), target, intent(in) :: array_m !< 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 @@ -652,7 +848,9 @@ subroutine chksum_u_2d(array, mesg, HI, haloshift, symmetric, omit_corners, & real, optional, intent(in) :: scale !< A scaling factor for this array. integer, optional, intent(in) :: logunit !< IO unit for checksum logging + real, pointer :: array(:,:) ! Field array on the input grid real, allocatable, dimension(:,:) :: rescaled_array + type(hor_index_type), pointer :: HI ! Horizontal index bounds of the input grid real :: scaling integer :: iounit !< Log IO unit integer :: i, j, Is @@ -660,6 +858,27 @@ subroutine chksum_u_2d(array, mesg, HI, haloshift, symmetric, omit_corners, & integer :: bc0, bcSW, bcSE, bcNW, bcNE, hshift integer :: bcN, bcS, bcE, bcW logical :: do_corners, sym, sym_stats + integer :: turns ! Quarter turns from input to model grid + + ! Rotate array to the input grid + turns = HI_m%turns + if (modulo(turns, 4) /= 0) then + allocate(HI) + call rotate_hor_index(HI_m, -turns, HI) + if (modulo(turns, 2) /= 0) then + ! Arrays originating from v-points must be handled by vchksum + allocate(array(HI%isd:HI%ied, HI%JsdB:HI%JedB)) + call rotate_array(array_m, -turns, array) + call vchksum(array, mesg, HI, haloshift, symmetric, omit_corners, scale, logunit) + return + else + allocate(array(HI%IsdB:HI%IedB, HI%jsd:HI%jed)) + call rotate_array(array_m, -turns, array) + endif + else + HI => HI_m + array => array_m + endif if (checkForNaNs) then if (is_NaN(array(HI%IscB:HI%IecB,HI%jsc:HI%jec))) & @@ -794,10 +1013,10 @@ end subroutine subStats end subroutine chksum_u_2d !> Checksums a 2d array staggered at C-grid v points. -subroutine chksum_v_2d(array, mesg, HI, haloshift, symmetric, omit_corners, & +subroutine chksum_v_2d(array_m, mesg, HI_m, haloshift, symmetric, omit_corners, & scale, logunit) - 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 + type(hor_index_type), target, intent(in) :: HI_m !< A horizontal index type + real, dimension(HI_m%isd:,HI_m%JsdB:), target, intent(in) :: array_m !< 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 @@ -806,7 +1025,9 @@ subroutine chksum_v_2d(array, mesg, HI, haloshift, symmetric, omit_corners, & real, optional, intent(in) :: scale !< A scaling factor for this array. integer, optional, intent(in) :: logunit !< IO unit for checksum logging + real, pointer :: array(:,:) ! Field array on the input grid real, allocatable, dimension(:,:) :: rescaled_array + type(hor_index_type), pointer :: HI ! Horizontal index bounds of the input grid real :: scaling integer :: iounit !< Log IO unit integer :: i, j, Js @@ -814,6 +1035,27 @@ subroutine chksum_v_2d(array, mesg, HI, haloshift, symmetric, omit_corners, & integer :: bc0, bcSW, bcSE, bcNW, bcNE, hshift integer :: bcN, bcS, bcE, bcW logical :: do_corners, sym, sym_stats + integer :: turns ! Quarter turns from input to model grid + + ! Rotate array to the input grid + turns = HI_m%turns + if (modulo(turns, 4) /= 0) then + allocate(HI) + call rotate_hor_index(HI_m, -turns, HI) + if (modulo(turns, 2) /= 0) then + ! Arrays originating from u-points must be handled by uchksum + allocate(array(HI%IsdB:HI%IedB, HI%jsd:HI%jed)) + call rotate_array(array_m, -turns, array) + call uchksum(array, mesg, HI, haloshift, symmetric, omit_corners, scale, logunit) + return + else + allocate(array(HI%isd:HI%ied, HI%JsdB:HI%JedB)) + call rotate_array(array_m, -turns, array) + endif + else + HI => HI_m + array => array_m + endif if (checkForNaNs) then if (is_NaN(array(HI%isc:HI%iec,HI%JscB:HI%JecB))) & @@ -948,16 +1190,18 @@ end subroutine subStats end subroutine chksum_v_2d !> Checksums a 3d array staggered at tracer points. -subroutine chksum_h_3d(array, mesg, HI, haloshift, omit_corners, scale, logunit) - 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 +subroutine chksum_h_3d(array_m, mesg, HI_m, haloshift, omit_corners, scale, logunit) + type(hor_index_type), target, intent(in) :: HI_m !< A horizontal index type + real, dimension(HI_m%isd:,HI_m%jsd:,:), target, intent(in) :: array_m !< 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) :: omit_corners !< If true, avoid checking diagonal shifts real, optional, intent(in) :: scale !< A scaling factor for this array. integer, optional, intent(in) :: logunit !< IO unit for checksum logging + real, pointer :: array(:,:,:) ! Field array on the input grid real, allocatable, dimension(:,:,:) :: rescaled_array + type(hor_index_type), pointer :: HI ! Horizontal index bounds of the input grid real :: scaling integer :: iounit !< Log IO unit integer :: i, j, k @@ -965,6 +1209,19 @@ subroutine chksum_h_3d(array, mesg, HI, haloshift, omit_corners, scale, logunit) integer :: bc0, bcSW, bcSE, bcNW, bcNE, hshift integer :: bcN, bcS, bcE, bcW logical :: do_corners + integer :: turns ! Quarter turns from input to model grid + + ! Rotate array to the input grid + turns = HI_m%turns + if (modulo(turns, 4) /= 0) then + allocate(HI) + call rotate_hor_index(HI_m, -turns, HI) + allocate(array(HI%isd:HI%ied, HI%jsd:HI%jed, size(array_m, 3))) + call rotate_array(array_m, -turns, array) + else + HI => HI_m + array => array_m + endif if (checkForNaNs) then if (is_NaN(array(HI%isc:HI%iec,HI%jsc:HI%jec,:))) & @@ -1080,10 +1337,10 @@ end subroutine subStats end subroutine chksum_h_3d !> Checksums a 3d array staggered at corner points. -subroutine chksum_B_3d(array, mesg, HI, haloshift, symmetric, omit_corners, & +subroutine chksum_B_3d(array_m, mesg, HI_m, haloshift, symmetric, omit_corners, & scale, logunit) - 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 + type(hor_index_type), target, intent(in) :: HI_m !< A horizontal index type + real, dimension(HI_m%IsdB:,HI_m%JsdB:,:), target, intent(in) :: array_m !< 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 @@ -1092,7 +1349,9 @@ subroutine chksum_B_3d(array, mesg, HI, haloshift, symmetric, omit_corners, & real, optional, intent(in) :: scale !< A scaling factor for this array. integer, optional, intent(in) :: logunit !< IO unit for checksum logging + real, pointer :: array(:,:,:) ! Field array on the input grid real, allocatable, dimension(:,:,:) :: rescaled_array + type(hor_index_type), pointer :: HI ! Horizontal index bounds of the input grid real :: scaling integer :: iounit !< Log IO unit integer :: i, j, k, Is, Js @@ -1100,6 +1359,19 @@ subroutine chksum_B_3d(array, mesg, HI, haloshift, symmetric, omit_corners, & integer :: bc0, bcSW, bcSE, bcNW, bcNE, hshift integer :: bcN, bcS, bcE, bcW logical :: do_corners, sym, sym_stats + integer :: turns ! Quarter turns from input to model grid + + ! Rotate array to the input grid + turns = HI_m%turns + if (modulo(turns, 4) /= 0) then + allocate(HI) + call rotate_hor_index(HI_m, -turns, HI) + allocate(array(HI%IsdB:HI%IedB, HI%JsdB:HI%JedB, size(array_m, 3))) + call rotate_array(array_m, -turns, array) + else + HI => HI_m + array => array_m + endif if (checkForNaNs) then if (is_NaN(array(HI%IscB:HI%IecB,HI%JscB:HI%JecB,:))) & @@ -1235,10 +1507,10 @@ end subroutine subStats end subroutine chksum_B_3d !> Checksums a 3d array staggered at C-grid u points. -subroutine chksum_u_3d(array, mesg, HI, haloshift, symmetric, omit_corners, & +subroutine chksum_u_3d(array_m, mesg, HI_m, haloshift, symmetric, omit_corners, & scale, logunit) - 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 + type(hor_index_type), target, intent(in) :: HI_m !< A horizontal index type + real, dimension(HI_m%isdB:,HI_m%Jsd:,:), target, intent(in) :: array_m !< 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 @@ -1247,7 +1519,9 @@ subroutine chksum_u_3d(array, mesg, HI, haloshift, symmetric, omit_corners, & real, optional, intent(in) :: scale !< A scaling factor for this array. integer, optional, intent(in) :: logunit !< IO unit for checksum logging + real, pointer :: array(:,:,:) ! Field array on the input grid real, allocatable, dimension(:,:,:) :: rescaled_array + type(hor_index_type), pointer :: HI ! Horizontal index bounds of the input grid real :: scaling integer :: iounit !< Log IO unit integer :: i, j, k, Is @@ -1255,6 +1529,27 @@ subroutine chksum_u_3d(array, mesg, HI, haloshift, symmetric, omit_corners, & integer :: bc0, bcSW, bcSE, bcNW, bcNE, hshift integer :: bcN, bcS, bcE, bcW logical :: do_corners, sym, sym_stats + integer :: turns ! Quarter turns from input to model grid + + ! Rotate array to the input grid + turns = HI_m%turns + if (modulo(turns, 4) /= 0) then + allocate(HI) + call rotate_hor_index(HI_m, -turns, HI) + if (modulo(turns, 2) /= 0) then + ! Arrays originating from v-points must be handled by vchksum + allocate(array(HI%isd:HI%ied, HI%JsdB:HI%JedB, size(array_m, 3))) + call rotate_array(array_m, -turns, array) + call vchksum(array, mesg, HI, haloshift, symmetric, omit_corners, scale, logunit) + return + else + allocate(array(HI%IsdB:HI%IedB, HI%jsd:HI%jed, size(array_m, 3))) + call rotate_array(array_m, -turns, array) + endif + else + HI => HI_m + array => array_m + endif if (checkForNaNs) then if (is_NaN(array(HI%IscB:HI%IecB,HI%jsc:HI%jec,:))) & @@ -1389,10 +1684,10 @@ end subroutine subStats end subroutine chksum_u_3d !> Checksums a 3d array staggered at C-grid v points. -subroutine chksum_v_3d(array, mesg, HI, haloshift, symmetric, omit_corners, & +subroutine chksum_v_3d(array_m, mesg, HI_m, haloshift, symmetric, omit_corners, & scale, logunit) - 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 + type(hor_index_type), target, intent(in) :: HI_m !< A horizontal index type + real, dimension(HI_m%isd:,HI_m%JsdB:,:), target, intent(in) :: array_m !< 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 @@ -1401,7 +1696,9 @@ subroutine chksum_v_3d(array, mesg, HI, haloshift, symmetric, omit_corners, & real, optional, intent(in) :: scale !< A scaling factor for this array. integer, optional, intent(in) :: logunit !< IO unit for checksum logging + real, pointer :: array(:,:,:) ! Field array on the input grid real, allocatable, dimension(:,:,:) :: rescaled_array + type(hor_index_type), pointer :: HI ! Horizontal index bounds of the input grid real :: scaling integer :: iounit !< Log IO unit integer :: i, j, k, Js @@ -1409,6 +1706,27 @@ subroutine chksum_v_3d(array, mesg, HI, haloshift, symmetric, omit_corners, & integer :: bcN, bcS, bcE, bcW real :: aMean, aMin, aMax logical :: do_corners, sym, sym_stats + integer :: turns ! Quarter turns from input to model grid + + ! Rotate array to the input grid + turns = HI_m%turns + if (modulo(turns, 4) /= 0) then + allocate(HI) + call rotate_hor_index(HI_m, -turns, HI) + if (modulo(turns, 2) /= 0) then + ! Arrays originating from u-points must be handled by uchksum + allocate(array(HI%IsdB:HI%IedB, HI%jsd:HI%jed, size(array_m, 3))) + call rotate_array(array_m, -turns, array) + call uchksum(array, mesg, HI, haloshift, symmetric, omit_corners, scale, logunit) + return + else + allocate(array(HI%isd:HI%ied, HI%JsdB:HI%JedB, size(array_m, 3))) + call rotate_array(array_m, -turns, array) + endif + else + HI => HI_m + array => array_m + endif if (checkForNaNs) then if (is_NaN(array(HI%isc:HI%iec,HI%JscB:HI%JecB,:))) & diff --git a/src/framework/MOM_domains.F90 b/src/framework/MOM_domains.F90 index 64fddfe7fc..477ebd70df 100644 --- a/src/framework/MOM_domains.F90 +++ b/src/framework/MOM_domains.F90 @@ -3,6 +3,7 @@ module MOM_domains ! This file is part of MOM6. See LICENSE.md for the license. +use MOM_array_transform, only : rotate_array use MOM_coms, only : PE_here, root_PE, num_PEs, MOM_infra_init, MOM_infra_end use MOM_coms, only : broadcast, sum_across_PEs, min_across_PEs, max_across_PEs use MOM_cpu_clock, only : cpu_clock_begin, cpu_clock_end @@ -1599,7 +1600,7 @@ end subroutine MOM_domains_init !> clone_MD_to_MD copies one MOM_domain_type into another, while allowing !! 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) + domain_name, turns) 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 @@ -1617,10 +1618,15 @@ subroutine clone_MD_to_MD(MD_in, MOM_dom, min_halo, halo_size, symmetric, & character(len=*), & optional, intent(in) :: domain_name !< A name for the new domain, "MOM" !! if missing. + integer, optional, intent(in) :: turns !< Number of quarter turns integer :: global_indices(4) logical :: mask_table_exists character(len=64) :: dom_name + integer :: qturns + + qturns = 0 + if (present(turns)) qturns = turns if (.not.associated(MOM_dom)) then allocate(MOM_dom) @@ -1629,19 +1635,37 @@ subroutine clone_MD_to_MD(MD_in, MOM_dom, min_halo, halo_size, symmetric, & endif ! Save the extra data for creating other domains of different resolution that overlay this domain - MOM_dom%niglobal = MD_in%niglobal ; MOM_dom%njglobal = MD_in%njglobal - MOM_dom%nihalo = MD_in%nihalo ; MOM_dom%njhalo = MD_in%njhalo - MOM_dom%symmetric = MD_in%symmetric MOM_dom%nonblocking_updates = MD_in%nonblocking_updates + MOM_dom%thin_halo_updates = MD_in%thin_halo_updates + + if (modulo(qturns, 2) /= 0) then + MOM_dom%niglobal = MD_in%njglobal ; MOM_dom%njglobal = MD_in%niglobal + MOM_dom%nihalo = MD_in%njhalo ; MOM_dom%njhalo = MD_in%nihalo - MOM_dom%X_FLAGS = MD_in%X_FLAGS ; MOM_dom%Y_FLAGS = MD_in%Y_FLAGS - MOM_dom%layout(:) = MD_in%layout(:) ; MOM_dom%io_layout(:) = MD_in%io_layout(:) + MOM_dom%X_FLAGS = MD_in%Y_FLAGS ; MOM_dom%Y_FLAGS = MD_in%X_FLAGS + MOM_dom%layout(:) = MD_in%layout(2:1:-1) + MOM_dom%io_layout(:) = MD_in%io_layout(2:1:-1) + else + MOM_dom%niglobal = MD_in%niglobal ; MOM_dom%njglobal = MD_in%njglobal + MOM_dom%nihalo = MD_in%nihalo ; MOM_dom%njhalo = MD_in%njhalo + + MOM_dom%X_FLAGS = MD_in%X_FLAGS ; MOM_dom%Y_FLAGS = MD_in%Y_FLAGS + MOM_dom%layout(:) = MD_in%layout(:) + MOM_dom%io_layout(:) = MD_in%io_layout(:) + endif + + global_indices(1) = 1 ; global_indices(2) = MOM_dom%niglobal + global_indices(3) = 1 ; global_indices(4) = MOM_dom%njglobal if (associated(MD_in%maskmap)) then mask_table_exists = .true. allocate(MOM_dom%maskmap(MOM_dom%layout(1), MOM_dom%layout(2))) - MOM_dom%maskmap(:,:) = MD_in%maskmap(:,:) + if (qturns /= 0) then + call rotate_array(MD_in%maskmap(:,:), qturns, MOM_dom%maskmap(:,:)) + else + MOM_dom%maskmap(:,:) = MD_in%maskmap(:,:) + endif else mask_table_exists = .false. endif @@ -1665,19 +1689,34 @@ subroutine clone_MD_to_MD(MD_in, MOM_dom, min_halo, halo_size, symmetric, & dom_name = "MOM" if (present(domain_name)) dom_name = trim(domain_name) - global_indices(1) = 1 ; global_indices(2) = MOM_dom%niglobal - global_indices(3) = 1 ; global_indices(4) = MOM_dom%njglobal if (mask_table_exists) then - call MOM_define_domain( global_indices, MOM_dom%layout, MOM_dom%mpp_domain, & + call MOM_define_domain(global_indices, MOM_dom%layout, MOM_dom%mpp_domain, & xflags=MOM_dom%X_FLAGS, yflags=MOM_dom%Y_FLAGS, & xhalo=MOM_dom%nihalo, yhalo=MOM_dom%njhalo, & - symmetry = MOM_dom%symmetric, name=dom_name, & - maskmap=MOM_dom%maskmap ) + symmetry=MOM_dom%symmetric, name=dom_name, & + maskmap=MOM_dom%maskmap) + + global_indices(2) = global_indices(2) / 2 + global_indices(4) = global_indices(4) / 2 + call MOM_define_domain(global_indices, MOM_dom%layout, & + MOM_dom%mpp_domain_d2, & + xflags=MOM_dom%X_FLAGS, yflags=MOM_dom%Y_FLAGS, & + xhalo=(MOM_dom%nihalo/2), yhalo=(MOM_dom%njhalo/2), & + symmetry=MOM_dom%symmetric, name=dom_name, & + maskmap=MOM_dom%maskmap) else - call MOM_define_domain( global_indices, MOM_dom%layout, MOM_dom%mpp_domain, & + call MOM_define_domain(global_indices, MOM_dom%layout, MOM_dom%mpp_domain, & xflags=MOM_dom%X_FLAGS, yflags=MOM_dom%Y_FLAGS, & xhalo=MOM_dom%nihalo, yhalo=MOM_dom%njhalo, & - symmetry = MOM_dom%symmetric, name=dom_name) + symmetry=MOM_dom%symmetric, name=dom_name) + + global_indices(2) = global_indices(2) / 2 + global_indices(4) = global_indices(4) / 2 + call MOM_define_domain(global_indices, MOM_dom%layout, & + MOM_dom%mpp_domain_d2, & + xflags=MOM_dom%X_FLAGS, yflags=MOM_dom%Y_FLAGS, & + xhalo=(MOM_dom%nihalo/2), yhalo=(MOM_dom%njhalo/2), & + symmetry=MOM_dom%symmetric, name=dom_name) endif if ((MOM_dom%io_layout(1) + MOM_dom%io_layout(2) > 0) .and. & @@ -1691,7 +1730,7 @@ end subroutine clone_MD_to_MD !! domain2d type, while allowing some properties of the new type to differ from !! the original one. subroutine clone_MD_to_d2D(MD_in, mpp_domain, min_halo, halo_size, symmetric, & - domain_name) + domain_name, turns) 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), & @@ -1707,12 +1746,16 @@ subroutine clone_MD_to_d2D(MD_in, mpp_domain, min_halo, halo_size, symmetric, & character(len=*), & optional, intent(in) :: domain_name !< A name for the new domain, "MOM" !! if missing. + integer, optional, intent(in) :: turns !< If true, swap X and Y axes integer :: global_indices(4), layout(2), io_layout(2) integer :: X_FLAGS, Y_FLAGS, niglobal, njglobal, nihalo, njhalo logical :: symmetric_dom character(len=64) :: dom_name + if (present(turns)) & + call MOM_error(FATAL, "Rotation not supported for MOM_domain to domain2d") + ! Save the extra data for creating other domains of different resolution that overlay this domain niglobal = MD_in%niglobal ; njglobal = MD_in%njglobal nihalo = MD_in%nihalo ; njhalo = MD_in%njhalo diff --git a/src/framework/MOM_dyn_horgrid.F90 b/src/framework/MOM_dyn_horgrid.F90 index ef74a12c9d..141340047d 100644 --- a/src/framework/MOM_dyn_horgrid.F90 +++ b/src/framework/MOM_dyn_horgrid.F90 @@ -173,7 +173,7 @@ module MOM_dyn_horgrid !--------------------------------------------------------------------- !> Allocate memory used by the dyn_horgrid_type and related structures. subroutine create_dyn_horgrid(G, HI, bathymetry_at_vel) - type(dyn_horgrid_type), pointer :: G !< A pointer to the dynamic horizontal grid type + type(dyn_horgrid_type), pointer, intent(inout) :: G !< A pointer to the dynamic horizontal grid type type(hor_index_type), intent(in) :: HI !< A hor_index_type for array extents logical, optional, intent(in) :: bathymetry_at_vel !< If true, there are !! separate values for the basin depths at velocity diff --git a/src/framework/MOM_hor_index.F90 b/src/framework/MOM_hor_index.F90 index db52afcdd8..fc833eeea9 100644 --- a/src/framework/MOM_hor_index.F90 +++ b/src/framework/MOM_hor_index.F90 @@ -10,6 +10,7 @@ module MOM_hor_index implicit none ; private public :: hor_index_init, assignment(=) +public :: rotate_hor_index !> Container for horizontal index ranges for data, computational and global domains type, public :: hor_index_type @@ -49,6 +50,8 @@ module MOM_hor_index integer :: niglobal !< The global number of h-cells in the i-direction integer :: njglobal !< The global number of h-cells in the j-direction + + integer :: turns !< Number of quarter-turn rotations from input to model end type hor_index_type !> Copy the contents of one horizontal index type into another @@ -92,6 +95,7 @@ subroutine hor_index_init(Domain, HI, param_file, local_indexing, index_offset) HI%IedB = HI%ied ; HI%JedB = HI%jed HI%IegB = HI%ieg ; HI%JegB = HI%jeg + HI%turns = 0 end subroutine hor_index_init !> HIT_assign copies one hor_index_type into another. It is accessed via an @@ -110,12 +114,57 @@ subroutine HIT_assign(HI1, HI2) HI1%IsdB = HI2%IsdB ; HI1%IedB = HI2%IedB ; HI1%JsdB = HI2%JsdB ; HI1%JedB = HI2%JedB HI1%IsgB = HI2%IsgB ; HI1%IegB = HI2%IegB ; HI1%JsgB = HI2%JsgB ; HI1%JegB = HI2%JegB + HI1%niglobal = HI2%niglobal ; HI1%njglobal = HI2%njglobal HI1%idg_offset = HI2%idg_offset ; HI1%jdg_offset = HI2%jdg_offset HI1%symmetric = HI2%symmetric - HI1%niglobal = HI2%niglobal ; HI1%njglobal = HI2%njglobal - + HI1%turns = HI2%turns end subroutine HIT_assign +!> Rotate the horizontal index ranges from the input to the output map. +subroutine rotate_hor_index(HI_in, turns, HI) + type(hor_index_type), intent(in) :: HI_in !< Unrotated horizontal indices + integer, intent(in) :: turns !< Number of quarter turns + type(hor_index_type), intent(inout) :: HI !< Rotated horizontal indices + + if (modulo(turns, 2) /= 0) then + HI%isc = HI_in%jsc + HI%iec = HI_in%jec + HI%jsc = HI_in%isc + HI%jec = HI_in%iec + HI%isd = HI_in%jsd + HI%ied = HI_in%jed + HI%jsd = HI_in%isd + HI%jed = HI_in%ied + HI%isg = HI_in%jsg + HI%ieg = HI_in%jeg + HI%jsg = HI_in%isg + HI%jeg = HI_in%ieg + + HI%IscB = HI_in%JscB + HI%IecB = HI_in%JecB + HI%JscB = HI_in%IscB + HI%JecB = HI_in%IecB + HI%IsdB = HI_in%JsdB + HI%IedB = HI_in%JedB + HI%JsdB = HI_in%IsdB + HI%JedB = HI_in%IedB + HI%IsgB = HI_in%JsgB + HI%IegB = HI_in%JegB + HI%JsgB = HI_in%IsgB + HI%JegB = HI_in%IegB + + HI%niglobal = HI_in%njglobal + HI%njglobal = HI_in%niglobal + HI%idg_offset = HI_in%jdg_offset + HI%jdg_offset = HI_in%idg_offset + + HI%symmetric = HI_in%symmetric + else + HI = HI_in + endif + HI%turns = HI_in%turns + turns +end subroutine rotate_hor_index + !> \namespace mom_hor_index !! !! The hor_index_type provides the declarations and loop ranges for almost all data with horizontal extent. diff --git a/src/framework/MOM_horizontal_regridding.F90 b/src/framework/MOM_horizontal_regridding.F90 index 7c19d715db..cd8a04f2fb 100644 --- a/src/framework/MOM_horizontal_regridding.F90 +++ b/src/framework/MOM_horizontal_regridding.F90 @@ -20,8 +20,9 @@ module MOM_horizontal_regridding use MOM_io, only : slasher, vardesc, write_field use MOM_string_functions, only : uppercase use MOM_time_manager, only : time_type, get_external_field_size -use MOM_time_manager, only : init_external_field, time_interp_external +use MOM_time_manager, only : init_external_field use MOM_time_manager, only : get_external_field_axes, get_external_field_missing +use MOM_transform_FMS, only : time_interp_external => rotated_time_interp_external use MOM_variables, only : thermo_var_ptrs use mpp_io_mod, only : axistype use mpp_domains_mod, only : mpp_global_field, mpp_get_compute_domain @@ -658,6 +659,9 @@ subroutine horiz_interp_and_extrap_tracer_fms_id(fms_id, Time, conversion, G, t real, dimension(SZI_(G),SZJ_(G)) :: tr_outf,tr_prev real, dimension(SZI_(G),SZJ_(G)) :: good2,fill2 real, dimension(SZI_(G),SZJ_(G)) :: nlevs + integer :: turns + + turns = G%HI%turns is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed @@ -753,7 +757,7 @@ subroutine horiz_interp_and_extrap_tracer_fms_id(fms_id, Time, conversion, G, t if (.not.spongeDataOngrid) then if (is_root_pe()) & - call time_interp_external(fms_id, Time, data_in, verbose=.true.) + call time_interp_external(fms_id, Time, data_in, verbose=.true., turns=turns) ! loop through each data level and interpolate to model grid. ! after interpolating, fill in points which will be needed ! to define the layers @@ -873,7 +877,7 @@ subroutine horiz_interp_and_extrap_tracer_fms_id(fms_id, Time, conversion, G, t enddo ! kd else - call time_interp_external(fms_id, Time, data_in, verbose=.true.) + call time_interp_external(fms_id, Time, data_in, verbose=.true., turns=turns) do k=1,kd do j=js,je do i=is,ie diff --git a/src/framework/MOM_restart.F90 b/src/framework/MOM_restart.F90 index ec9789c20b..c918f3a9ee 100644 --- a/src/framework/MOM_restart.F90 +++ b/src/framework/MOM_restart.F90 @@ -9,16 +9,18 @@ module MOM_restart use MOM_string_functions, only : lowercase use MOM_grid, only : ocean_grid_type use MOM_io, only : create_file, fieldtype, file_exists, open_file, close_file -use MOM_io, only : write_field, MOM_read_data, read_data, get_filename_appendix +use MOM_io, only : MOM_read_data, read_data, get_filename_appendix use MOM_io, only : get_file_info, get_file_atts, get_file_fields, get_file_times use MOM_io, only : vardesc, var_desc, query_vardesc, modify_vardesc use MOM_io, only : MULTIPLE, NETCDF_FILE, READONLY_FILE, SINGLE_FILE use MOM_io, only : CENTER, CORNER, NORTH_FACE, EAST_FACE use MOM_time_manager, only : time_type, time_type_to_real, real_to_time use MOM_time_manager, only : days_in_month, get_date, set_date +use MOM_transform_FMS, only : mpp_chksum => rotated_mpp_chksum +use MOM_transform_FMS, only : write_field => rotated_write_field use MOM_verticalGrid, only : verticalGrid_type -use mpp_mod, only: mpp_chksum,mpp_pe -use mpp_io_mod, only: mpp_attribute_exist, mpp_get_atts +use mpp_io_mod, only : mpp_attribute_exist, mpp_get_atts +use mpp_mod, only : mpp_pe implicit none ; private @@ -26,6 +28,7 @@ module MOM_restart public save_restart, query_initialized, restart_init_end, vardesc public restart_files_exist, determine_is_new_run, is_new_run public register_restart_field_as_obsolete +public register_restart_pair !> A type for making arrays of pointers to 4-d arrays type p4d @@ -86,6 +89,7 @@ module MOM_restart !! made from a run with a different mask_table than the current run, !! in which case the checksums will not match and cause crash. character(len=240) :: restartfile !< The name or name root for MOM restart files. + integer :: turns !< Number of quarter turns from input to model domain !> An array of descriptions of the registered fields type(field_restart), pointer :: restart_field(:) => NULL() @@ -112,6 +116,13 @@ module MOM_restart module procedure register_restart_field_ptr0d, register_restart_field_0d end interface +!> Register a pair of restart fieilds whose rotations map onto each other +interface register_restart_pair + module procedure register_restart_pair_ptr2d + module procedure register_restart_pair_ptr3d + module procedure register_restart_pair_ptr4d +end interface register_restart_pair + !> Indicate whether a field has been read from a restart file interface query_initialized module procedure query_initialized_name @@ -287,6 +298,67 @@ subroutine register_restart_field_ptr0d(f_ptr, var_desc, mandatory, CS) end subroutine register_restart_field_ptr0d + +!> Register a pair of rotationally equivalent 2d restart fields +subroutine register_restart_pair_ptr2d(a_ptr, b_ptr, a_desc, b_desc, & + mandatory, CS) + real, dimension(:,:), target, intent(in) :: a_ptr !< First field pointer + real, dimension(:,:), target, intent(in) :: b_ptr !< Second field pointer + type(vardesc), intent(in) :: a_desc !< First field descriptor + type(vardesc), intent(in) :: b_desc !< Second field descriptor + logical, intent(in) :: mandatory !< If true, abort if field is missing + type(MOM_restart_CS), pointer :: CS !< MOM restart control structure + + if (modulo(CS%turns, 2) /= 0) then + call register_restart_field(b_ptr, a_desc, mandatory, CS) + call register_restart_field(a_ptr, b_desc, mandatory, CS) + else + call register_restart_field(a_ptr, a_desc, mandatory, CS) + call register_restart_field(b_ptr, b_desc, mandatory, CS) + endif +end subroutine register_restart_pair_ptr2d + + +!> Register a pair of rotationally equivalent 3d restart fields +subroutine register_restart_pair_ptr3d(a_ptr, b_ptr, a_desc, b_desc, & + mandatory, CS) + real, dimension(:,:,:), target, intent(in) :: a_ptr !< First field pointer + real, dimension(:,:,:), target, intent(in) :: b_ptr !< Second field pointer + type(vardesc), intent(in) :: a_desc !< First field descriptor + type(vardesc), intent(in) :: b_desc !< Second field descriptor + logical, intent(in) :: mandatory !< If true, abort if field is missing + type(MOM_restart_CS), pointer :: CS !< MOM restart control structure + + if (modulo(CS%turns, 2) /= 0) then + call register_restart_field(b_ptr, a_desc, mandatory, CS) + call register_restart_field(a_ptr, b_desc, mandatory, CS) + else + call register_restart_field(a_ptr, a_desc, mandatory, CS) + call register_restart_field(b_ptr, b_desc, mandatory, CS) + endif +end subroutine register_restart_pair_ptr3d + + +!> Register a pair of rotationally equivalent 2d restart fields +subroutine register_restart_pair_ptr4d(a_ptr, b_ptr, a_desc, b_desc, & + mandatory, CS) + real, dimension(:,:,:,:), target, intent(in) :: a_ptr !< First field pointer + real, dimension(:,:,:,:), target, intent(in) :: b_ptr !< Second field pointer + type(vardesc), intent(in) :: a_desc !< First field descriptor + type(vardesc), intent(in) :: b_desc !< Second field descriptor + logical, intent(in) :: mandatory !< If true, abort if field is missing + type(MOM_restart_CS), pointer :: CS !< MOM restart control structure + + if (modulo(CS%turns, 2) /= 0) then + call register_restart_field(b_ptr, a_desc, mandatory, CS) + call register_restart_field(a_ptr, b_desc, mandatory, CS) + else + call register_restart_field(a_ptr, a_desc, mandatory, CS) + call register_restart_field(b_ptr, b_desc, mandatory, CS) + endif +end subroutine register_restart_pair_ptr4d + + ! The following provide alternate interfaces to register restarts. !> Register a 4-d field for restarts, providing the metadata as individual arguments @@ -815,6 +887,9 @@ subroutine save_restart(directory, time, G, CS, time_stamped, filename, GV) integer :: length integer(kind=8) :: check_val(CS%max_fields,1) integer :: isL, ieL, jsL, jeL, pos + integer :: turns + + turns = CS%turns if (.not.associated(CS)) call MOM_error(FATAL, "MOM_restart " // & "save_restart: Module must be initialized before it is used.") @@ -927,14 +1002,21 @@ subroutine save_restart(directory, time, G, CS, time_stamped, filename, GV) end select !Prepare the checksum of the restart fields to be written to restart files - call get_checksum_loop_ranges(G, pos, isL, ieL, jsL, jeL) + if (modulo(turns, 2) /= 0) then + call get_checksum_loop_ranges(G, pos, jsL, jeL, isL, ieL) + else + call get_checksum_loop_ranges(G, pos, isL, ieL, jsL, jeL) + endif do m=start_var,next_var-1 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,:)) + check_val(m-start_var+1,1) = & + mpp_chksum(CS%var_ptr3d(m)%p(isL:ieL,jsL:jeL,:), turns=-turns) elseif (associated(CS%var_ptr2d(m)%p)) then - check_val(m-start_var+1,1) = mpp_chksum(CS%var_ptr2d(m)%p(isL:ieL,jsL:jeL)) + check_val(m-start_var+1,1) = & + mpp_chksum(CS%var_ptr2d(m)%p(isL:ieL,jsL:jeL), turns=-turns) elseif (associated(CS%var_ptr4d(m)%p)) then - check_val(m-start_var+1,1) = mpp_chksum(CS%var_ptr4d(m)%p(isL:ieL,jsL:jeL,:,:)) + check_val(m-start_var+1,1) = & + mpp_chksum(CS%var_ptr4d(m)%p(isL:ieL,jsL:jeL,:,:), turns=-turns) elseif (associated(CS%var_ptr1d(m)%p)) then check_val(m-start_var+1,1) = mpp_chksum(CS%var_ptr1d(m)%p) elseif (associated(CS%var_ptr0d(m)%p)) then @@ -951,16 +1033,15 @@ subroutine save_restart(directory, time, G, CS, time_stamped, filename, GV) endif do m=start_var,next_var-1 - 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) + CS%var_ptr3d(m)%p, restart_time, turns=-turns) 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) + CS%var_ptr2d(m)%p, restart_time, turns=-turns) 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) + CS%var_ptr4d(m)%p, restart_time, turns=-turns) elseif (associated(CS%var_ptr1d(m)%p)) then call write_field(unit, fields(m-start_var+1), CS%var_ptr1d(m)%p, & restart_time) @@ -1425,6 +1506,8 @@ subroutine restart_init(param_file, CS, restart_root) !! set by RESTARTFILE to enable the use of this module by !! other components than MOM. + logical :: rotate_index + ! This include declares and sets the variable "version". #include "version_variable.h" character(len=40) :: mdl = "MOM_restart" ! This module's name. @@ -1464,6 +1547,16 @@ subroutine restart_init(param_file, CS, restart_root) "in which case the checksums will not match and cause crash.",& default=.true.) + ! Maybe not the best place to do this? + call get_param(param_file, mdl, "ROTATE_INDEX", rotate_index, & + default=.false., do_not_log=.true.) + + CS%turns = 0 + if (rotate_index) then + call get_param(param_file, mdl, "INDEX_TURNS", CS%turns, & + default=1, do_not_log=.true.) + endif + allocate(CS%restart_field(CS%max_fields)) allocate(CS%restart_obsolete(CS%max_fields)) allocate(CS%var_ptr0d(CS%max_fields)) diff --git a/src/framework/MOM_transform_FMS.F90 b/src/framework/MOM_transform_FMS.F90 new file mode 100644 index 0000000000..2af6088c90 --- /dev/null +++ b/src/framework/MOM_transform_FMS.F90 @@ -0,0 +1,399 @@ +!> Support functions and interfaces to permit transformed model domains to +!! interact with FMS operations registered on the non-transformed domains. + +module MOM_transform_FMS + +use horiz_interp_mod, only : horiz_interp_type +use MOM_error_handler, only : MOM_error, FATAL +use MOM_io, only : fieldtype, write_field +use mpp_domains_mod, only : domain2D +use fms_mod, only : mpp_chksum +use time_manager_mod, only : time_type +use time_interp_external_mod, only : time_interp_external + +use MOM_array_transform, only : allocate_rotated_array, rotate_array + +implicit none + +private +public rotated_mpp_chksum +public rotated_write_field +public rotated_time_interp_external + +!> Rotate and compute the FMS (mpp) checksum of a field +interface rotated_mpp_chksum + module procedure rotated_mpp_chksum_real_0d + module procedure rotated_mpp_chksum_real_1d + module procedure rotated_mpp_chksum_real_2d + module procedure rotated_mpp_chksum_real_3d + module procedure rotated_mpp_chksum_real_4d +end interface rotated_mpp_chksum + +!> Rotate and write a registered field to an FMS output file +interface rotated_write_field + module procedure rotated_write_field_real_0d + module procedure rotated_write_field_real_1d + module procedure rotated_write_field_real_2d + module procedure rotated_write_field_real_3d + module procedure rotated_write_field_real_4d +end interface rotated_write_field + +!> Read a field based on model time, and rotate to the model domain +interface rotated_time_interp_external + module procedure rotated_time_interp_external_0d + module procedure rotated_time_interp_external_2d + module procedure rotated_time_interp_external_3d +end interface rotated_time_interp_external + +contains + +! NOTE: No transformations are applied to the 0d and 1d field implementations, +! but are provided to maintain compatibility with the FMS interfaces. + + +!> Compute the FMS (mpp) checksum of a scalar. +!! This function is provided to support the full FMS mpp_chksum interface. +function rotated_mpp_chksum_real_0d(field, pelist, mask_val, turns) & + result(chksum) + real, intent(in) :: field !> Input scalar + integer, optional, intent(in) :: pelist(:) !> PE list of ranks to checksum + real, optional, intent(in) :: mask_val !> FMS mask value + integer, optional, intent(in) :: turns !> Number of quarter turns + integer :: chksum !> FMS checksum of scalar + + if (present(turns)) & + call MOM_error(FATAL, "Rotation not supported for 0d fields.") + + chksum = mpp_chksum(field, pelist=pelist, mask_val=mask_val) +end function rotated_mpp_chksum_real_0d + + +!> Compute the FMS (mpp) checksum of a 1d field. +!! This function is provided to support the full FMS mpp_chksum interface. +function rotated_mpp_chksum_real_1d(field, pelist, mask_val, turns) & + result(chksum) + real, intent(in) :: field(:) !> Input field + integer, optional, intent(in) :: pelist(:) !> PE list of ranks to checksum + real, optional, intent(in) :: mask_val !> FMS mask value + integer, optional, intent(in) :: turns !> Number of quarter-turns + integer :: chksum !> FMS checksum of field + + if (present(turns)) & + call MOM_error(FATAL, "Rotation not supported for 1d fields.") + + chksum = mpp_chksum(field, pelist=pelist, mask_val=mask_val) +end function rotated_mpp_chksum_real_1d + + +!> Compute the FMS (mpp) checksum of a rotated 2d field. +function rotated_mpp_chksum_real_2d(field, pelist, mask_val, turns) & + result(chksum) + real, intent(in) :: field(:,:) !> Unrotated input field + integer, optional, intent(in) :: pelist(:) !> PE list of ranks to checksum + real, optional, intent(in) :: mask_val !> FMS mask value + integer, optional, intent(in) :: turns !> Number of quarter-turns + integer :: chksum !> FMS checksum of field + + real, allocatable :: field_rot(:,:) + integer :: qturns + + qturns = 0 + if (present(turns)) & + qturns = turns + + if (qturns == 0) then + chksum = mpp_chksum(field, pelist=pelist, mask_val=mask_val) + else + call allocate_rotated_array(field, [1,1], qturns, field_rot) + call rotate_array(field, qturns, field_rot) + chksum = mpp_chksum(field_rot, pelist=pelist, mask_val=mask_val) + deallocate(field_rot) + endif +end function rotated_mpp_chksum_real_2d + + +!> Compute the FMS (mpp) checksum of a rotated 3d field. +function rotated_mpp_chksum_real_3d(field, pelist, mask_val, turns) & + result(chksum) + real, intent(in) :: field(:,:,:) !> Unrotated input field + integer, optional, intent(in) :: pelist(:) !> PE list of ranks to checksum + real, optional, intent(in) :: mask_val !> FMS mask value + integer, optional, intent(in) :: turns !> Number of quarter-turns + integer :: chksum !> FMS checksum of field + + real, allocatable :: field_rot(:,:,:) + integer :: qturns + + qturns = 0 + if (present(turns)) & + qturns = turns + + if (qturns == 0) then + chksum = mpp_chksum(field, pelist=pelist, mask_val=mask_val) + else + call allocate_rotated_array(field, [1,1,1], qturns, field_rot) + call rotate_array(field, qturns, field_rot) + chksum = mpp_chksum(field_rot, pelist=pelist, mask_val=mask_val) + deallocate(field_rot) + endif +end function rotated_mpp_chksum_real_3d + + +!> Compute the FMS (mpp) checksum of a rotated 4d field. +function rotated_mpp_chksum_real_4d(field, pelist, mask_val, turns) & + result(chksum) + real, intent(in) :: field(:,:,:,:) !> Unrotated input field + integer, optional, intent(in) :: pelist(:) !> PE list of ranks to checksum + real, optional, intent(in) :: mask_val !> FMS mask value + integer, optional, intent(in) :: turns !> Number of quarter-turns + integer :: chksum !> FMS checksum of field + + real, allocatable :: field_rot(:,:,:,:) + integer :: qturns + + qturns = 0 + if (present(turns)) & + qturns = turns + + if (qturns == 0) then + chksum = mpp_chksum(field, pelist=pelist, mask_val=mask_val) + else + call allocate_rotated_array(field, [1,1,1,1], qturns, field_rot) + call rotate_array(field, qturns, field_rot) + chksum = mpp_chksum(field_rot, pelist=pelist, mask_val=mask_val) + deallocate(field_rot) + endif +end function rotated_mpp_chksum_real_4d + + +! NOTE: In MOM_io, write_field points to mpp_write, which supports a very broad +! range of interfaces. Here, we only support the much more narrow family of +! mpp_write_2ddecomp functions used to write tiled data. + + +!> Write the rotation of a 1d field to an FMS output file +!! This function is provided to support the full FMS write_field interface. +subroutine rotated_write_field_real_0d(io_unit, field_md, field, tstamp, turns) + integer, intent(in) :: io_unit !> File I/O unit handle + type(fieldtype), intent(in) :: field_md !> FMS field metadata + real, intent(inout) :: field !> Unrotated field array + real, optional, intent(in) :: tstamp !> Model timestamp + integer, optional, intent(in) :: turns !> Number of quarter-turns + + if (present(turns)) & + call MOM_error(FATAL, "Rotation not supported for 0d fields.") + + call write_field(io_unit, field_md, field, tstamp=tstamp) +end subroutine rotated_write_field_real_0d + + +!> Write the rotation of a 1d field to an FMS output file +!! This function is provided to support the full FMS write_field interface. +subroutine rotated_write_field_real_1d(io_unit, field_md, field, tstamp, turns) + integer, intent(in) :: io_unit !> File I/O unit handle + type(fieldtype), intent(in) :: field_md !> FMS field metadata + real, intent(inout) :: field(:) !> Unrotated field array + real, optional, intent(in) :: tstamp !> Model timestamp + integer, optional, intent(in) :: turns !> Number of quarter-turns + + if (present(turns)) & + call MOM_error(FATAL, "Rotation not supported for 0d fields.") + + call write_field(io_unit, field_md, field, tstamp=tstamp) +end subroutine rotated_write_field_real_1d + + +!> Write the rotation of a 2d field to an FMS output file +subroutine rotated_write_field_real_2d(io_unit, field_md, domain, field, & + tstamp, tile_count, default_data, turns) + integer, intent(in) :: io_unit !> File I/O unit handle + type(fieldtype), intent(in) :: field_md !> FMS field metadata + type(domain2D), intent(inout) :: domain !> FMS MPP domain + real, intent(inout) :: field(:,:) !> Unrotated field array + real, optional, intent(in) :: tstamp !> Model timestamp + integer, optional, intent(in) :: tile_count !> PEs per tile (default: 1) + real, optional, intent(in) :: default_data !> Default fill value + integer, optional, intent(in) :: turns !> Number of quarter-turns + + real, allocatable :: field_rot(:,:) + integer :: qturns + + qturns = 0 + if (present(turns)) & + qturns = turns + + if (qturns == 0) then + call write_field(io_unit, field_md, domain, field, tstamp=tstamp, & + tile_count=tile_count, default_data=default_data) + else + call allocate_rotated_array(field, [1,1], qturns, field_rot) + call rotate_array(field, qturns, field_rot) + call write_field(io_unit, field_md, domain, field_rot, tstamp=tstamp, & + tile_count=tile_count, default_data=default_data) + deallocate(field_rot) + endif +end subroutine rotated_write_field_real_2d + + +!> Write the rotation of a 3d field to an FMS output file +subroutine rotated_write_field_real_3d(io_unit, field_md, domain, field, & + tstamp, tile_count, default_data, turns) + integer, intent(in) :: io_unit !> File I/O unit handle + type(fieldtype), intent(in) :: field_md !> FMS field metadata + type(domain2D), intent(inout) :: domain !> FMS MPP domain + real, intent(inout) :: field(:,:,:) !> Unrotated field array + real, optional, intent(in) :: tstamp !> Model timestamp + integer, optional, intent(in) :: tile_count !> PEs per tile (default: 1) + real, optional, intent(in) :: default_data !> Default fill value + integer, optional, intent(in) :: turns !> Number of quarter-turns + + real, allocatable :: field_rot(:,:,:) + integer :: qturns + + qturns = 0 + if (present(turns)) & + qturns = turns + + if (qturns == 0) then + call write_field(io_unit, field_md, domain, field, tstamp=tstamp, & + tile_count=tile_count, default_data=default_data) + else + call allocate_rotated_array(field, [1,1,1], qturns, field_rot) + call rotate_array(field, qturns, field_rot) + call write_field(io_unit, field_md, domain, field_rot, tstamp=tstamp, & + tile_count=tile_count, default_data=default_data) + deallocate(field_rot) + endif +end subroutine rotated_write_field_real_3d + + +!> Write the rotation of a 4d field to an FMS output file +subroutine rotated_write_field_real_4d(io_unit, field_md, domain, field, & + tstamp, tile_count, default_data, turns) + integer, intent(in) :: io_unit !> File I/O unit handle + type(fieldtype), intent(in) :: field_md !> FMS field metadata + type(domain2D), intent(inout) :: domain !> FMS MPP domain + real, intent(inout) :: field(:,:,:,:) !> Unrotated field array + real, optional, intent(in) :: tstamp !> Model timestamp + integer, optional, intent(in) :: tile_count !> PEs per tile (default: 1) + real, optional, intent(in) :: default_data !> Default fill value + integer, optional, intent(in) :: turns !> Number of quarter-turns + + real, allocatable :: field_rot(:,:,:,:) + integer :: qturns + + qturns = 0 + if (present(turns)) qturns = turns + + if (qturns == 0) then + call write_field(io_unit, field_md, domain, field, tstamp=tstamp, & + tile_count=tile_count, default_data=default_data) + else + call allocate_rotated_array(field, [1,1,1,1], qturns, field_rot) + call rotate_array(field, qturns, field_rot) + call write_field(io_unit, field_md, domain, field_rot, tstamp=tstamp, & + tile_count=tile_count, default_data=default_data) + deallocate(field_rot) + endif +end subroutine rotated_write_field_real_4d + + +!> Read a scalar field based on model time +!! This function is provided to support the full FMS time_interp_external +!! interface. +subroutine rotated_time_interp_external_0d(fms_id, time, data_in, verbose, & + turns) + integer, intent(in) :: fms_id !< FMS field ID + type(time_type), intent(in) :: time !< Model time + real, intent(inout) :: data_in !< field to write data + logical, intent(in), optional :: verbose !< Verbose output + integer, intent(in), optional :: turns !< Number of quarter turns + + if (present(turns)) & + call MOM_error(FATAL, "Rotation not supported for 0d fields.") + + call time_interp_external(fms_id, time, data_in, verbose=verbose) +end subroutine rotated_time_interp_external_0d + +!> Read a 2d field based on model time, and rotate to the model grid +subroutine rotated_time_interp_external_2d(fms_id, time, data_in, interp, & + verbose, horz_interp, mask_out, is_in, ie_in, js_in, je_in, window_id, & + turns) + integer, intent(in) :: fms_id + type(time_type), intent(in) :: time + real, dimension(:,:), intent(inout) :: data_in + integer, intent(in), optional :: interp + logical, intent(in), optional :: verbose + type(horiz_interp_type),intent(in), optional :: horz_interp + logical, dimension(:,:), intent(out), optional :: mask_out + integer, intent(in), optional :: is_in, ie_in, js_in, je_in + integer, intent(in), optional :: window_id + integer, intent(in), optional :: turns + + real, allocatable :: data_pre(:,:) + integer :: qturns + + ! TODO: Mask rotation requires logical array rotation support + if (present(mask_out)) & + call MOM_error(FATAL, "Rotation of masked output not yet support") + + qturns = 0 + if (present(turns)) qturns = turns + + if (qturns == 0) then + call time_interp_external(fms_id, time, data_in, interp=interp, & + verbose=verbose, horz_interp=horz_interp, mask_out=mask_out, & + is_in=is_in, ie_in=ie_in, js_in=js_in, je_in=je_in, & + window_id=window_id) + else + call allocate_rotated_array(data_in, [1,1], -qturns, data_pre) + call time_interp_external(fms_id, time, data_pre, interp=interp, & + verbose=verbose, horz_interp=horz_interp, mask_out=mask_out, & + is_in=is_in, ie_in=ie_in, js_in=js_in, je_in=je_in, & + window_id=window_id) + call rotate_array(data_pre, turns, data_in) + endif +end subroutine rotated_time_interp_external_2d + + +!> Read a 3d field based on model time, and rotate to the model grid +subroutine rotated_time_interp_external_3d(fms_id, time, data_in, interp, & + verbose, horz_interp, mask_out, is_in, ie_in, js_in, je_in, window_id, & + turns) + integer, intent(in) :: fms_id + type(time_type), intent(in) :: time + real, dimension(:,:,:), intent(inout) :: data_in + integer, intent(in), optional :: interp + logical, intent(in), optional :: verbose + type(horiz_interp_type),intent(in), optional :: horz_interp + logical, dimension(:,:,:), intent(out), optional :: mask_out + integer, intent(in), optional :: is_in, ie_in, js_in, je_in + integer, intent(in), optional :: window_id + integer, intent(in), optional :: turns + + real, allocatable :: data_pre(:,:,:) + integer :: qturns + + ! TODO: Mask rotation requires logical array rotation support + if (present(mask_out)) & + call MOM_error(FATAL, "Rotation of masked output not yet support") + + qturns = 0 + if (present(turns)) qturns = turns + + if (qturns == 0) then + call time_interp_external(fms_id, time, data_in, interp=interp, & + verbose=verbose, horz_interp=horz_interp, mask_out=mask_out, & + is_in=is_in, ie_in=ie_in, js_in=js_in, je_in=je_in, & + window_id=window_id) + else + call allocate_rotated_array(data_in, [1,1,1], -qturns, data_pre) + call time_interp_external(fms_id, time, data_pre, interp=interp, & + verbose=verbose, horz_interp=horz_interp, mask_out=mask_out, & + is_in=is_in, ie_in=ie_in, js_in=js_in, je_in=je_in, & + window_id=window_id) + call rotate_array(data_pre, turns, data_in) + endif +end subroutine rotated_time_interp_external_3d + +end module MOM_transform_FMS diff --git a/src/initialization/MOM_grid_initialize.F90 b/src/initialization/MOM_grid_initialize.F90 index 1c594f45c1..45c903f4ff 100644 --- a/src/initialization/MOM_grid_initialize.F90 +++ b/src/initialization/MOM_grid_initialize.F90 @@ -125,7 +125,8 @@ subroutine grid_metrics_chksum(parent, G, US) halo = min(G%ied-G%iec, G%jed-G%jec, 1) - call hchksum_pair(trim(parent)//': d[xy]T', G%dxT, G%dyT, G%HI, haloshift=halo, scale=L_to_m) + call hchksum_pair(trim(parent)//': d[xy]T', G%dxT, G%dyT, G%HI, & + haloshift=halo, scale=L_to_m, scalar_pair=.true.) call uvchksum(trim(parent)//': dxC[uv]', G%dxCu, G%dyCv, G%HI, haloshift=halo, scale=L_to_m) @@ -133,7 +134,8 @@ subroutine grid_metrics_chksum(parent, G, US) call Bchksum_pair(trim(parent)//': dxB[uv]', G%dxBu, G%dyBu, G%HI, haloshift=halo, scale=L_to_m) - call hchksum_pair(trim(parent)//': Id[xy]T', G%IdxT, G%IdyT, G%HI, haloshift=halo, scale=m_to_L) + call hchksum_pair(trim(parent)//': Id[xy]T', G%IdxT, G%IdyT, G%HI, & + haloshift=halo, scale=m_to_L, scalar_pair=.true.) call uvchksum(trim(parent)//': Id[xy]C[uv]', G%IdxCu, G%IdyCv, G%HI, haloshift=halo, scale=m_to_L) diff --git a/src/initialization/MOM_shared_initialization.F90 b/src/initialization/MOM_shared_initialization.F90 index 3338f1fedb..9311003863 100644 --- a/src/initialization/MOM_shared_initialization.F90 +++ b/src/initialization/MOM_shared_initialization.F90 @@ -1202,6 +1202,8 @@ subroutine write_ocean_geometry_file(G, param_file, directory, geom_file, US) real, dimension(G%IsdB:G%IedB,G%jsd :G%jed ) :: out_u real, dimension(G%isd :G%ied ,G%JsdB:G%JedB) :: out_v + call callTree_enter('write_ocean_geometry_file()') + 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 @@ -1331,6 +1333,7 @@ subroutine write_ocean_geometry_file(G, param_file, directory, geom_file, US) call close_file(unit) + call callTree_leave('write_ocean_geometry_file()') end subroutine write_ocean_geometry_file end module MOM_shared_initialization diff --git a/src/parameterizations/lateral/MOM_MEKE.F90 b/src/parameterizations/lateral/MOM_MEKE.F90 index 4033d64f3c..eedd9e9268 100644 --- a/src/parameterizations/lateral/MOM_MEKE.F90 +++ b/src/parameterizations/lateral/MOM_MEKE.F90 @@ -196,8 +196,10 @@ subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt, G, GV, US, CS, hu, h if (associated(MEKE%GM_src)) & call hchksum(MEKE%GM_src, 'MEKE GM_src', G%HI, scale=US%RZ3_T3_to_W_m2*US%L_to_Z**2) if (associated(MEKE%MEKE)) call hchksum(MEKE%MEKE, 'MEKE MEKE', G%HI, scale=US%L_T_to_m_s**2) - call uvchksum("MEKE SN_[uv]", SN_u, SN_v, G%HI, scale=US%s_to_T) - call uvchksum("MEKE h[uv]", hu, hv, G%HI, haloshift=1, scale=GV%H_to_m*US%L_to_m**2) + call uvchksum("MEKE SN_[uv]", SN_u, SN_v, G%HI, scale=US%s_to_T, & + scalar_pair=.true.) + call uvchksum("MEKE h[uv]", hu, hv, G%HI, haloshift=1, & + scale=GV%H_to_m*(US%L_to_m**2)) endif sdt = dt*CS%MEKE_dtScale ! Scaled dt to use for time-stepping @@ -287,7 +289,8 @@ subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt, G, GV, US, CS, hu, h call MEKE_lengthScales(CS, MEKE, G, GV, US, SN_u, SN_v, MEKE%MEKE, bottomFac2, barotrFac2, LmixScale) if (CS%debug) then if (CS%visc_drag) & - call uvchksum("MEKE drag_vel_[uv]", drag_vel_u, drag_vel_v, G%HI, scale=US%Z_to_m*US%s_to_T) + call uvchksum("MEKE drag_vel_[uv]", drag_vel_u, drag_vel_v, G%HI, & + scale=US%Z_to_m*US%s_to_T, scalar_pair=.true.) call hchksum(mass, 'MEKE mass',G%HI,haloshift=1, scale=US%RZ_to_kg_m2) call hchksum(drag_rate_visc, 'MEKE drag_rate_visc', G%HI, scale=US%L_T_to_m_s) call hchksum(bottomFac2, 'MEKE bottomFac2', G%HI) diff --git a/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 b/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 index 0e237fac55..e5e699ebee 100644 --- a/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 +++ b/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 @@ -602,9 +602,12 @@ subroutine calc_Visbeck_coeffs(h, slope_x, slope_y, N2_u, N2_v, G, GV, US, CS) endif if (CS%debug) then - call uvchksum("calc_Visbeck_coeffs slope_[xy]", slope_x, slope_y, G%HI, haloshift=1) - call uvchksum("calc_Visbeck_coeffs N2_u, N2_v", N2_u, N2_v, G%HI, scale=US%s_to_T**2) - call uvchksum("calc_Visbeck_coeffs SN_[uv]", CS%SN_u, CS%SN_v, G%HI, scale=US%s_to_T) + call uvchksum("calc_Visbeck_coeffs slope_[xy]", slope_x, slope_y, G%HI, & + haloshift=1) + call uvchksum("calc_Visbeck_coeffs N2_u, N2_v", N2_u, N2_v, G%HI, & + scale=US%s_to_T**2, scalar_pair=.true.) + call uvchksum("calc_Visbeck_coeffs SN_[uv]", CS%SN_u, CS%SN_v, G%HI, & + scale=US%s_to_T, scalar_pair=.true.) endif end subroutine calc_Visbeck_coeffs diff --git a/src/parameterizations/lateral/MOM_thickness_diffuse.F90 b/src/parameterizations/lateral/MOM_thickness_diffuse.F90 index 4da62ed5df..6796da5b57 100644 --- a/src/parameterizations/lateral/MOM_thickness_diffuse.F90 +++ b/src/parameterizations/lateral/MOM_thickness_diffuse.F90 @@ -422,7 +422,8 @@ subroutine thickness_diffuse(h, uhtr, vhtr, tv, dt, G, GV, US, MEKE, VarMix, CDp endif if (CS%debug) then - call uvchksum("Kh_[uv]", Kh_u, Kh_v, G%HI, haloshift=0, scale=US%L_to_m**2*US%s_to_T) + call uvchksum("Kh_[uv]", Kh_u, Kh_v, G%HI, haloshift=0, & + scale=(US%L_to_m**2)*US%s_to_T, scalar_pair=.true.) call uvchksum("int_slope_[uv]", int_slope_u, int_slope_v, G%HI, haloshift=0) call hchksum(h, "thickness_diffuse_1 h", G%HI, haloshift=1, scale=GV%H_to_m) call hchksum(e, "thickness_diffuse_1 e", G%HI, haloshift=1, scale=US%Z_to_m) diff --git a/src/parameterizations/vertical/MOM_ALE_sponge.F90 b/src/parameterizations/vertical/MOM_ALE_sponge.F90 index ccd85280f5..b791535ed1 100644 --- a/src/parameterizations/vertical/MOM_ALE_sponge.F90 +++ b/src/parameterizations/vertical/MOM_ALE_sponge.F90 @@ -12,6 +12,7 @@ module MOM_ALE_sponge ! This file is part of MOM6. See LICENSE.md for the license. +use MOM_array_transform, only: rotate_array use MOM_coms, only : sum_across_PEs use MOM_diag_mediator, only : post_data, query_averaging_enabled, register_diag_field use MOM_diag_mediator, only : diag_ctrl @@ -54,6 +55,7 @@ module MOM_ALE_sponge 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 +public rotate_ALE_sponge, update_ALE_sponge_field ! A note on unit descriptions in comments: MOM6 uses units that can be rescaled for dimensional ! consistency testing. These are noted in comments with units like Z, H, L, and T, along with @@ -999,6 +1001,163 @@ subroutine apply_ALE_sponge(h, dt, G, GV, US, CS, Time) end subroutine apply_ALE_sponge +!> Rotate the ALE sponge fields from the input to the model index map. +subroutine rotate_ALE_sponge(sponge_in, G_in, sponge, G, turns, param_file) + type(ALE_sponge_CS), intent(in) :: sponge_in + type(ocean_grid_type), intent(in) :: G_in + type(ALE_sponge_CS), pointer :: sponge + type(ocean_grid_type), intent(in) :: G + integer, intent(in) :: turns + type(param_file_type), intent(in) :: param_file + + ! First part: Index construction + ! 1. Reconstruct Iresttime(:,:) from sponge_in + ! 2. rotate Iresttime(:,:) + ! 3. Call initialize_sponge using new grid and rotated Iresttime(:,:) + ! All the index adjustment should follow from the Iresttime rotation + + real, dimension(:,:), allocatable :: Iresttime_in, Iresttime + real, dimension(:,:,:), allocatable :: data_h_in, data_h + real, dimension(:,:,:), allocatable :: sp_val_in, sp_val + real, dimension(:,:,:), pointer :: sp_ptr => NULL() + integer :: c, c_i, c_j + integer :: k, nz_data + integer :: n + logical :: fixed_sponge + + fixed_sponge = .not. sponge_in%time_varying_sponges + ! NOTE: nz_data is only conditionally set when fixed_sponge is true. + + allocate(Iresttime_in(G_in%isd:G_in%ied, G_in%jsd:G_in%jed)) + allocate(Iresttime(G%isd:G%ied, G%jsd:G%jed)) + Iresttime_in(:,:) = 0.0 + + if (fixed_sponge) then + nz_data = sponge_in%nz_data + allocate(data_h_in(G_in%isd:G_in%ied, G_in%jsd:G_in%jed, nz_data)) + allocate(data_h(G%isd:G%ied, G%jsd:G%jed, nz_data)) + data_h_in(:,:,:) = 0. + endif + + ! Re-populate the 2D Iresttime and data_h arrays on the original grid + do c = 1, sponge_in%num_col + c_i = sponge_in%col_i(c) + c_j = sponge_in%col_j(c) + Iresttime_in(c_i, c_j) = sponge_in%Iresttime_col(c) + if (fixed_sponge) then + do k = 1, nz_data + data_h(c_i, c_j, k) = sponge_in%Ref_h%p(k,c) + enddo + endif + enddo + + call rotate_array(Iresttime_in, turns, Iresttime) + if (fixed_sponge) then + call rotate_array(data_h_in, turns, data_h) + call initialize_ALE_sponge_fixed(Iresttime, G, param_file, sponge, & + data_h, nz_data) + else + call initialize_ALE_sponge_varying(Iresttime, G, param_file, sponge) + endif + + deallocate(Iresttime_in) + deallocate(Iresttime) + if (fixed_sponge) then + deallocate(data_h_in) + deallocate(data_h) + endif + + ! Second part: Provide rotated fields for which relaxation is applied + + sponge%fldno = sponge_in%fldno + + if (fixed_sponge) then + allocate(sp_val_in(G_in%isd:G_in%ied, G_in%jsd:G_in%jed, nz_data)) + allocate(sp_val(G%isd:G%ied, G%jsd:G%jed, nz_data)) + endif + + do n = 1, sponge_in%fldno + ! Assume that tracers are pointers and are remapped in other functions(?) + sp_ptr => sponge_in%var(n)%p + sp_val_in(:,:,:) = 0.0 + do c = 1, sponge_in%num_col + c_i = sponge_in%col_i(c) + c_j = sponge_in%col_j(c) + if (fixed_sponge) then + do k = 1, nz_data + sp_val_in(c_i, c_j, k) = sponge_in%Ref_val(n)%p(k,c) + enddo + endif + enddo + + call rotate_array(sp_val_in, turns, sp_val) + if (fixed_sponge) then + ! NOTE: This points sp_val with the unrotated field. See note below. + call set_up_ALE_sponge_field(sp_val, G, sp_ptr, sponge) + else + ! We don't want to repeat FMS init in set_up_ALE_sponge_field_varying() + ! (time_interp_external_init, init_external_field, etc), so we manually + ! do a portion of this function below. + sponge%Ref_val(n)%id = sponge_in%Ref_val(n)%id + sponge%Ref_val(n)%num_tlevs = sponge_in%Ref_val(n)%num_tlevs + + nz_data = sponge_in%Ref_val(n)%nz_data + sponge%Ref_val(n)%nz_data = nz_data + + allocate(sponge%Ref_val(n)%p(nz_data, sponge_in%num_col)) + allocate(sponge%Ref_val(n)%h(nz_data, sponge_in%num_col)) + sponge%Ref_val(n)%p(:,:) = 0.0 + sponge%Ref_val(n)%h(:,:) = 0.0 + + ! TODO: There is currently no way to associate a generic field pointer to + ! its rotated equivalent without introducing a new data structure which + ! explicitly tracks the pairing. + ! + ! As a temporary fix, we store the pointer to the unrotated field in + ! the rotated sponge, and use this reference to replace the pointer + ! to the rotated field update_ALE_sponge field. + ! + ! This makes a lot of unverifiable assumptions, and should not be + ! considered the final solution. + sponge%var(n)%p => sp_ptr + endif + enddo + + if (fixed_sponge) then + deallocate(sp_val_in) + deallocate(sp_val) + endif + + ! TODO: var_u and var_v sponge dampling is not yet supported. + if (associated(sponge_in%var_u%p) .or. associated(sponge_in%var_v%p)) & + call MOM_error(FATAL, "Rotation of ALE sponge velocities is not yet " & + // "implemented.") + + ! Transfer any existing diag_CS reference pointer + sponge%diag => sponge_in%diag + + ! NOTE: initialize_ALE_sponge_* resolves remap_cs +end subroutine rotate_ALE_sponge + + +!> Scan the ALE sponge variables and replace a prescribed pointer to a new value. +! TODO: This function solely exists to replace field pointers in the sponge +! after rotation. This function is part of a temporary solution until +! something more robust is developed. +subroutine update_ALE_sponge_field(sponge, p_old, p_new) + type(ALE_sponge_CS), pointer :: sponge + real, dimension(:,:,:), target, intent(in) :: p_old + real, dimension(:,:,:), target, intent(in) :: p_new + + integer :: n + + do n = 1, sponge%fldno + if (associated(sponge%var(n)%p, p_old)) & + sponge%var(n)%p => p_new + enddo +end subroutine update_ALE_sponge_field + + ! GMM: I could not find where sponge_end is being called, but I am keeping ! ALE_sponge_end here so we can add that if needed. !> This subroutine deallocates any memory associated with the ALE_sponge module. diff --git a/src/parameterizations/vertical/MOM_set_diffusivity.F90 b/src/parameterizations/vertical/MOM_set_diffusivity.F90 index 3045639232..d7dfcea090 100644 --- a/src/parameterizations/vertical/MOM_set_diffusivity.F90 +++ b/src/parameterizations/vertical/MOM_set_diffusivity.F90 @@ -3,12 +3,11 @@ module MOM_set_diffusivity ! This file is part of MOM6. See LICENSE.md for the license. -use MOM_checksums, only : hchksum_pair 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 : diag_ctrl, time_type use MOM_diag_mediator, only : post_data, register_diag_field -use MOM_debugging, only : hchksum, uvchksum, Bchksum +use MOM_debugging, only : hchksum, uvchksum, Bchksum, hchksum_pair use MOM_EOS, only : calculate_density, calculate_density_derivs use MOM_error_handler, only : MOM_error, is_root_pe, FATAL, WARNING, NOTE use MOM_error_handler, only : callTree_showQuery @@ -536,13 +535,15 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, & 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., scale=US%Z2_T_to_m2_s) + call uvchksum("BBL Kv_bbl_[uv]", visc%kv_bbl_u, visc%kv_bbl_v, G%HI, & + haloshift=0, symmetric=.true., scale=US%Z2_T_to_m2_s, & + scalar_pair=.true.) endif if (associated(visc%bbl_thick_u) .and. associated(visc%bbl_thick_v)) then - call uvchksum("BBL bbl_thick_[uv]", visc%bbl_thick_u, & - visc%bbl_thick_v, G%HI, 0, symmetric=.true., scale=US%Z_to_m) + call uvchksum("BBL bbl_thick_[uv]", visc%bbl_thick_u, visc%bbl_thick_v, & + G%HI, haloshift=0, symmetric=.true., scale=US%Z_to_m, & + scalar_pair=.true.) endif if (associated(visc%Ray_u) .and. associated(visc%Ray_v)) then diff --git a/src/parameterizations/vertical/MOM_set_viscosity.F90 b/src/parameterizations/vertical/MOM_set_viscosity.F90 index f5412facae..062642c3da 100644 --- a/src/parameterizations/vertical/MOM_set_viscosity.F90 +++ b/src/parameterizations/vertical/MOM_set_viscosity.F90 @@ -943,10 +943,11 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, symmetrize) if (associated(visc%Ray_u) .and. associated(visc%Ray_v)) & call uvchksum("Ray [uv]", visc%Ray_u, visc%Ray_v, G%HI, haloshift=0, scale=US%Z_to_m) if (associated(visc%kv_bbl_u) .and. associated(visc%kv_bbl_v)) & - call uvchksum("kv_bbl_[uv]", visc%kv_bbl_u, visc%kv_bbl_v, G%HI, haloshift=0, scale=US%Z2_T_to_m2_s) + call uvchksum("kv_bbl_[uv]", visc%kv_bbl_u, visc%kv_bbl_v, G%HI, & + haloshift=0, scale=US%Z2_T_to_m2_s, scalar_pair=.true.) if (associated(visc%bbl_thick_u) .and. associated(visc%bbl_thick_v)) & - call uvchksum("bbl_thick_[uv]", visc%bbl_thick_u, & - visc%bbl_thick_v, G%HI, haloshift=0, scale=US%Z_to_m) + call uvchksum("bbl_thick_[uv]", visc%bbl_thick_u, visc%bbl_thick_v, & + G%HI, haloshift=0, scale=US%Z_to_m, scalar_pair=.true.) endif end subroutine set_viscous_BBL @@ -1710,8 +1711,8 @@ subroutine set_viscous_ML(u, v, h, tv, forces, visc, dt, G, GV, US, CS, symmetri if (CS%debug) then if (associated(visc%nkml_visc_u) .and. associated(visc%nkml_visc_v)) & - call uvchksum("nkml_visc_[uv]", visc%nkml_visc_u, & - visc%nkml_visc_v, G%HI,haloshift=0) + call uvchksum("nkml_visc_[uv]", visc%nkml_visc_u, visc%nkml_visc_v, & + G%HI, haloshift=0, scalar_pair=.true.) endif if (CS%id_nkml_visc_u > 0) & call post_data(CS%id_nkml_visc_u, visc%nkml_visc_u, CS%diag) diff --git a/src/parameterizations/vertical/MOM_vert_friction.F90 b/src/parameterizations/vertical/MOM_vert_friction.F90 index 5a610095ce..b4e2e302c8 100644 --- a/src/parameterizations/vertical/MOM_vert_friction.F90 +++ b/src/parameterizations/vertical/MOM_vert_friction.F90 @@ -558,7 +558,8 @@ subroutine vertvisc_remnant(visc, visc_rem_u, visc_rem_v, dt, G, GV, US, CS) enddo ! end of v-component J loop if (CS%debug) then - call uvchksum("visc_rem_[uv]", visc_rem_u, visc_rem_v, G%HI,haloshift=0) + call uvchksum("visc_rem_[uv]", visc_rem_u, visc_rem_v, G%HI, haloshift=0, & + scalar_pair=.true.) endif end subroutine vertvisc_remnant @@ -1008,10 +1009,13 @@ subroutine vertvisc_coef(u, v, h, forces, visc, dt, G, GV, US, CS, OBC) enddo ! end of v-point j loop if (CS%debug) then - call uvchksum("vertvisc_coef h_[uv]", CS%h_u, CS%h_v, G%HI, haloshift=0, scale=GV%H_to_m) - call uvchksum("vertvisc_coef a_[uv]", CS%a_u, CS%a_v, G%HI, haloshift=0, scale=US%Z_to_m*US%s_to_T) + call uvchksum("vertvisc_coef h_[uv]", CS%h_u, CS%h_v, G%HI, haloshift=0, & + scale=GV%H_to_m, scalar_pair=.true.) + call uvchksum("vertvisc_coef a_[uv]", CS%a_u, CS%a_v, G%HI, haloshift=0, & + scale=US%Z_to_m*US%s_to_T, scalar_pair=.true.) if (allocated(hML_u) .and. allocated(hML_v)) & - call uvchksum("vertvisc_coef hML_[uv]", hML_u, hML_v, G%HI, haloshift=0, scale=GV%H_to_m) + call uvchksum("vertvisc_coef hML_[uv]", hML_u, hML_v, G%HI, & + haloshift=0, scale=GV%H_to_m, scalar_pair=.true.) endif ! Offer diagnostic fields for averaging. diff --git a/src/tracer/MOM_tracer_hor_diff.F90 b/src/tracer/MOM_tracer_hor_diff.F90 index d18bb3e330..aec9c8ccf2 100644 --- a/src/tracer/MOM_tracer_hor_diff.F90 +++ b/src/tracer/MOM_tracer_hor_diff.F90 @@ -556,10 +556,12 @@ subroutine tracer_hordiff(h, dt, MEKE, VarMix, G, GV, US, CS, Reg, tv, do_online if (CS%debug) then call uvchksum("After tracer diffusion khdt_[xy]", khdt_x, khdt_y, & - G%HI, haloshift=0, symmetric=.true., scale=US%L_to_m**2) + G%HI, haloshift=0, symmetric=.true., scale=US%L_to_m**2, & + scalar_pair=.true.) if (CS%use_neutral_diffusion) then call uvchksum("After tracer diffusion Coef_[xy]", Coef_x, Coef_y, & - G%HI, haloshift=0, symmetric=.true., scale=US%L_to_m**2) + G%HI, haloshift=0, symmetric=.true., scale=US%L_to_m**2, & + scalar_pair=.true.) endif endif From b72afce2b01521950630393e75340f795fee6b9f Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Tue, 14 Apr 2020 16:44:14 -0400 Subject: [PATCH 178/316] +Made arguments to unit_scaling_init optional Made both arguments to unit_scaling_init optional to enable the use of this routine to initialize unscaled unit_scale_types for certain types of unit testing. All answers are bitwise identical. --- src/framework/MOM_unit_scaling.F90 | 31 ++++++++++++++++++------------ 1 file changed, 19 insertions(+), 12 deletions(-) diff --git a/src/framework/MOM_unit_scaling.F90 b/src/framework/MOM_unit_scaling.F90 index 7ef0486c0e..ffd2452c19 100644 --- a/src/framework/MOM_unit_scaling.F90 +++ b/src/framework/MOM_unit_scaling.F90 @@ -54,8 +54,8 @@ module MOM_unit_scaling !> Allocates and initializes the ocean model unit scaling type subroutine unit_scaling_init( param_file, US ) - type(param_file_type), intent(in) :: param_file !< Parameter file handle/type - type(unit_scale_type), pointer :: US !< A dimensional unit scaling type + type(param_file_type), optional, intent(in) :: param_file !< Parameter file handle/type + type(unit_scale_type), optional, pointer :: US !< A dimensional unit scaling type ! This routine initializes a unit_scale_type structure (US). @@ -66,33 +66,40 @@ subroutine unit_scaling_init( param_file, US ) # include "version_variable.h" character(len=16) :: mdl = "MOM_unit_scaling" + if (.not.present(US)) return + if (associated(US)) call MOM_error(FATAL, & 'unit_scaling_init: called with an associated US pointer.') allocate(US) - ! Read all relevant parameters and write them to the model log. - call log_version(param_file, mdl, version, & - "Parameters for doing unit scaling of variables.") - call get_param(param_file, mdl, "Z_RESCALE_POWER", Z_power, & + if (present(param_file)) then + ! Read all relevant parameters and write them to the model log. + call log_version(param_file, mdl, version, & + "Parameters for doing unit scaling of variables.") + call get_param(param_file, mdl, "Z_RESCALE_POWER", Z_power, & "An integer power of 2 that is used to rescale the model's "//& "internal units of depths and heights. Valid values range from -300 to 300.", & units="nondim", default=0, debuggingParam=.true.) - call get_param(param_file, mdl, "L_RESCALE_POWER", L_power, & + call get_param(param_file, mdl, "L_RESCALE_POWER", L_power, & "An integer power of 2 that is used to rescale the model's "//& "internal units of lateral distances. Valid values range from -300 to 300.", & units="nondim", default=0, debuggingParam=.true.) - call get_param(param_file, mdl, "T_RESCALE_POWER", T_power, & + call get_param(param_file, mdl, "T_RESCALE_POWER", T_power, & "An integer power of 2 that is used to rescale the model's "//& "internal units of time. Valid values range from -300 to 300.", & units="nondim", default=0, debuggingParam=.true.) - call get_param(param_file, mdl, "R_RESCALE_POWER", R_power, & + call get_param(param_file, mdl, "R_RESCALE_POWER", R_power, & "An integer power of 2 that is used to rescale the model's "//& "internal units of density. Valid values range from -300 to 300.", & units="nondim", default=0, debuggingParam=.true.) - call get_param(param_file, mdl, "Q_RESCALE_POWER", Q_power, & + call get_param(param_file, mdl, "Q_RESCALE_POWER", Q_power, & "An integer power of 2 that is used to rescale the model's "//& - "internal units of heat content. Valid values range from -300 to 300.", & - units="nondim", default=0, debuggingParam=.true.) + "internal units of heat content. Valid values range from -300 to 300.", & + units="nondim", default=0, debuggingParam=.true.) + else + Z_power = 0 ; L_power = 0 ; T_power = 0 ; R_power = 0 ; Q_power = 0 + endif + if (abs(Z_power) > 300) call MOM_error(FATAL, "unit_scaling_init: "//& "Z_RESCALE_POWER is outside of the valid range of -300 to 300.") if (abs(L_power) > 300) call MOM_error(FATAL, "unit_scaling_init: "//& From a7836f0a7cec7bc36b8e79095cde743114d89147 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Tue, 14 Apr 2020 16:45:24 -0400 Subject: [PATCH 179/316] +Rescaled variables in MOM_neutral_diffusion.F90 Rescaled pressure and density variables in MOM_neutral_diffusion and added numerous comments describing internal variables and their units. Some unused variables were deleted, including unused pressure arguments to find_neutral_pos_linear. In addition unit_scale_type arguments were added to 8 subroutines, including neutral_diffusion_init and tracer_hor_diff_init. All answers are bitwise identical, but there are changes to public interfaces. --- src/tracer/MOM_neutral_diffusion.F90 | 661 ++++++++++++++------------- src/tracer/MOM_tracer_hor_diff.F90 | 6 +- 2 files changed, 347 insertions(+), 320 deletions(-) diff --git a/src/tracer/MOM_neutral_diffusion.F90 b/src/tracer/MOM_neutral_diffusion.F90 index 26873900cc..0f025c3d39 100644 --- a/src/tracer/MOM_neutral_diffusion.F90 +++ b/src/tracer/MOM_neutral_diffusion.F90 @@ -19,7 +19,7 @@ module MOM_neutral_diffusion use MOM_remapping, only : extract_member_remapping_CS, build_reconstructions_1d use MOM_remapping, only : average_value_ppoly, remappingSchemesDoc, remappingDefaultScheme use MOM_tracer_registry, only : tracer_registry_type, tracer_type -use MOM_unit_scaling, only : unit_scale_type +use MOM_unit_scaling, only : unit_scale_type, unit_scaling_init use MOM_verticalGrid, only : verticalGrid_type use polynomial_functions, only : evaluation_polynomial, first_derivative_polynomial use PPM_functions, only : PPM_reconstruction, PPM_boundary_extrapolation @@ -45,9 +45,10 @@ module MOM_neutral_diffusion logical :: debug = .false. !< If true, write verbose debugging messages logical :: hard_fail_heff !< Bring down the model if a problem with heff is detected integer :: max_iter !< Maximum number of iterations if refine_position is defined - real :: drho_tol !< Convergence criterion representing difference from true neutrality + real :: drho_tol !< Convergence criterion representing density difference from true neutrality [R ~> kg m-3] real :: x_tol !< Convergence criterion for how small an update of the position can be - real :: ref_pres !< Reference pressure, negative if using locally referenced neutral density + real :: ref_pres !< Reference pressure, negative if using locally referenced neutral + !! density [R L2 T-2 ~> Pa] logical :: interior_only !< If true, only applies neutral diffusion in the ocean interior. !! That is, the algorithm will exclude the surface and bottom boundary layers. ! Positions of neutral surfaces in both the u, v directions @@ -69,17 +70,17 @@ module MOM_neutral_diffusion real, allocatable, dimension(:,:,:,:) :: ppoly_coeffs_T !< Polynomial coefficients for temperature real, allocatable, dimension(:,:,:,:) :: ppoly_coeffs_S !< Polynomial coefficients for salinity ! Variables needed for continuous reconstructions - real, allocatable, dimension(:,:,:) :: dRdT !< dRho/dT [kg m-3 degC-1] at interfaces - real, allocatable, dimension(:,:,:) :: dRdS !< dRho/dS [kg m-3 ppt-1] at interfaces + real, allocatable, dimension(:,:,:) :: dRdT !< dRho/dT [R degC-1 ~> kg m-3 degC-1] at interfaces + real, allocatable, dimension(:,:,:) :: dRdS !< dRho/dS [R ppt-1 ~> kg m-3 ppt-1] at interfaces real, allocatable, dimension(:,:,:) :: Tint !< Interface T [degC] real, allocatable, dimension(:,:,:) :: Sint !< Interface S [ppt] - real, allocatable, dimension(:,:,:) :: Pint !< Interface pressure [Pa] + real, allocatable, dimension(:,:,:) :: Pint !< Interface pressure [R L2 T-2 ~> Pa] ! Variables needed for discontinuous reconstructions - real, allocatable, dimension(:,:,:,:) :: T_i !< Top edge reconstruction of temperature (degC) - real, allocatable, dimension(:,:,:,:) :: S_i !< Top edge reconstruction of salinity (ppt) - real, allocatable, dimension(:,:,:,:) :: P_i !< Interface pressure (Pa) - 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 + real, allocatable, dimension(:,:,:,:) :: T_i !< Top edge reconstruction of temperature [degC] + real, allocatable, dimension(:,:,:,:) :: S_i !< Top edge reconstruction of salinity [ppt] + real, allocatable, dimension(:,:,:,:) :: P_i !< Interface pressures [R L2 T-2 ~> Pa] + real, allocatable, dimension(:,:,:,:) :: dRdT_i !< dRho/dT [R degC-1 ~> kg m-3 degC-1] at top edge + real, allocatable, dimension(:,:,:,:) :: dRdS_i !< dRho/dS [R ppt-1 ~> kg m-3 ppt-1] 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 type(diag_ctrl), pointer :: diag => NULL() !< A structure that is used to @@ -91,7 +92,6 @@ module MOM_neutral_diffusion integer :: id_uhEff_2d = -1 !< Diagnostic IDs integer :: id_vhEff_2d = -1 !< Diagnostic IDs - real :: C_p !< heat capacity of seawater (J kg-1 K-1) type(EOS_type), pointer :: EOS !< Equation of state parameters type(remapping_CS) :: remap_CS !< Remapping control structure used to create sublayers logical :: remap_answers_2018 !< If true, use the order of arithmetic and expressions that @@ -108,9 +108,10 @@ module MOM_neutral_diffusion contains !> Read parameters and allocate control structure for neutral_diffusion module. -logical function neutral_diffusion_init(Time, G, param_file, diag, EOS, diabatic_CSp, CS) +logical function neutral_diffusion_init(Time, G, US, param_file, diag, EOS, diabatic_CSp, CS) type(time_type), target, intent(in) :: Time !< Time structure type(ocean_grid_type), intent(in) :: G !< Grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(diag_ctrl), target, intent(inout) :: diag !< Diagnostics control structure type(param_file_type), intent(in) :: param_file !< Parameter file structure type(EOS_type), target, intent(in) :: EOS !< Equation of state @@ -154,9 +155,9 @@ logical function neutral_diffusion_init(Time, G, param_file, diag, EOS, diabatic "a higher computational cost.", default=.true.) call get_param(param_file, mdl, "NDIFF_REF_PRES", CS%ref_pres, & "The reference pressure (Pa) used for the derivatives of "//& - "the equation of state. If negative (default), local "//& - "pressure is used.", units="Pa", default = -1.) - call get_param(param_file, mdl, "NDIFF_INTERIOR_ONLY", CS%interior_only, & + "the equation of state. If negative (default), local pressure is used.", & + units="Pa", default = -1., scale=US%kg_m3_to_R*US%m_s_to_L_T**2) + call get_param(param_file, mdl, "NDIFF_INTERIOR_ONLY", CS%interior_only, & "If true, only applies neutral diffusion in the ocean interior."//& "That is, the algorithm will exclude the surface and bottom"//& "boundary layers.", default = .false.) @@ -203,7 +204,7 @@ logical function neutral_diffusion_init(Time, G, param_file, diag, EOS, diabatic call get_param(param_file, mdl, "NDIFF_DRHO_TOL", CS%drho_tol, & "Sets the convergence criterion for finding the neutral\n"// & "position within a layer in kg m-3.", & - default=1.e-10) + default=1.e-10, scale=US%kg_m3_to_R) call get_param(param_file, mdl, "NDIFF_X_TOL", CS%x_tol, & "Sets the convergence criterion for a change in nondim\n"// & "position within a layer.", & @@ -287,7 +288,7 @@ subroutine neutral_diffusion_calc_coeffs(G, GV, US, h, T, S, CS) real, dimension(SZI_(G), SZJ_(G)) :: hEff_sum ! Summed effective face thicknesses [H ~> m or kg m-2] real, dimension(SZI_(G),SZJ_(G)) :: hbl ! Boundary layer depth [m] integer :: iMethod - real, dimension(SZI_(G)) :: ref_pres ! Reference pressure used to calculate alpha/beta + real, dimension(SZI_(G)) :: ref_pres ! Reference pressure used to calculate alpha/beta [R L2 T-2 ~> Pa] real, dimension(SZI_(G)) :: rho_tmp ! Routine to calculate drho_dp, returns density which is not used real :: h_neglect, h_neglect_edge ! Negligible thicknesses [H ~> m or kg m-2] integer, dimension(SZI_(G), SZJ_(G)) :: k_top ! Index of the first layer within the boundary @@ -295,9 +296,9 @@ subroutine neutral_diffusion_calc_coeffs(G, GV, US, h, T, S, CS) ! top extent of the boundary layer (0 at top, 1 at bottom) [nondim] integer, dimension(SZI_(G), SZJ_(G)) :: k_bot ! Index of the last layer within the boundary real, dimension(SZI_(G), SZJ_(G)) :: zeta_bot ! Distance of the lower layer to the boundary layer depth - real :: pa_to_H ! A conversion factor from Pa to H [H Pa-1 ~> m Pa-1 or s2 m-2] + real :: pa_to_H ! A conversion factor from pressure to H units [H T2 R-1 Z-2 ~> m Pa-1 or s2 m-2] - pa_to_H = 1. / GV%H_to_pa + pa_to_H = 1. / (GV%H_to_RZ * GV%g_Earth) k_top(:,:) = 1 ; k_bot(:,:) = 1 zeta_top(:,:) = 0. ; zeta_bot(:,:) = 1. @@ -340,10 +341,11 @@ subroutine neutral_diffusion_calc_coeffs(G, GV, US, h, T, S, CS) CS%stable_cell(:,:,:) = .true. endif + ! ### Consider adding the surface pressures to both Pint and P_i. ! Calculate pressure at interfaces and layer averaged alpha/beta CS%Pint(:,:,1) = 0. do k=1,G%ke ; do j=G%jsc-1, G%jec+1 ; do i=G%isc-1,G%iec+1 - CS%Pint(i,j,k+1) = CS%Pint(i,j,k) + h(i,j,k)*GV%H_to_Pa + CS%Pint(i,j,k+1) = CS%Pint(i,j,k) + h(i,j,k)*(GV%g_Earth*GV%H_to_RZ) enddo ; enddo ; enddo ! Pressures at the interfaces, this is redundant as P_i(k,1) = P_i(k-1,2) however retain tis @@ -351,11 +353,11 @@ subroutine neutral_diffusion_calc_coeffs(G, GV, US, h, T, S, CS) if (.not. CS%continuous_reconstruction) then do j=G%jsc-1, G%jec+1 ; do i=G%isc-1,G%iec+1 CS%P_i(i,j,1,1) = 0. - CS%P_i(i,j,1,2) = h(i,j,1)*GV%H_to_Pa + CS%P_i(i,j,1,2) = h(i,j,1)*(GV%H_to_RZ*GV%g_Earth) enddo ; enddo do k=2,G%ke ; do j=G%jsc-1, G%jec+1 ; do i=G%isc-1,G%iec+1 CS%P_i(i,j,k,1) = CS%P_i(i,j,k-1,2) - CS%P_i(i,j,k,2) = CS%P_i(i,j,k-1,2) + h(i,j,k)*GV%H_to_Pa + CS%P_i(i,j,k,2) = CS%P_i(i,j,k-1,2) + h(i,j,k)*(GV%H_to_RZ*GV%g_Earth) enddo ; enddo ; enddo endif @@ -386,27 +388,25 @@ subroutine neutral_diffusion_calc_coeffs(G, GV, US, h, T, S, CS) do k = 1, G%ke+1 if (CS%ref_pres<0) ref_pres(:) = CS%Pint(:,j,k) call calculate_density_derivs(CS%Tint(:,j,k), CS%Sint(:,j,k), ref_pres, & - CS%dRdT(:,j,k), CS%dRdS(:,j,k), G%isc-1, G%iec-G%isc+3, CS%EOS) + CS%dRdT(:,j,k), CS%dRdS(:,j,k), G%isc-1, G%iec-G%isc+3, CS%EOS, US) enddo else ! Discontinuous reconstruction do k = 1, G%ke if (CS%ref_pres<0) ref_pres(:) = CS%Pint(:,j,k) ! Calculate derivatives for the top interface call calculate_density_derivs(CS%T_i(:,j,k,1), CS%S_i(:,j,k,1), ref_pres, & - CS%dRdT_i(:,j,k,1), CS%dRdS_i(:,j,k,1), G%isc-1, G%iec-G%isc+3, CS%EOS) - if (CS%ref_pres<0) then - ref_pres(:) = CS%Pint(:,j,k+1) - endif + CS%dRdT_i(:,j,k,1), CS%dRdS_i(:,j,k,1), G%isc-1, G%iec-G%isc+3, CS%EOS, US) + if (CS%ref_pres<0) ref_pres(:) = CS%Pint(:,j,k+1) ! Calcualte derivatives at the bottom interface call calculate_density_derivs(CS%T_i(:,j,k,2), CS%S_i(:,j,k,2), ref_pres, & - CS%dRdT_i(:,j,k,2), CS%dRdS_i(:,j,k,2), G%isc-1, G%iec-G%isc+3, CS%EOS) + CS%dRdT_i(:,j,k,2), CS%dRdS_i(:,j,k,2), G%isc-1, G%iec-G%isc+3, CS%EOS, US) enddo endif enddo if (.not. CS%continuous_reconstruction) then do j = G%jsc-1, G%jec+1 ; do i = G%isc-1, G%iec+1 - call mark_unstable_cells( CS, G%ke, CS%T_i(i,j,:,:), CS%S_i(i,j,:,:), CS%P_i(i,j,:,:), CS%stable_cell(i,j,:) ) + call mark_unstable_cells( CS, G%ke, CS%T_i(i,j,:,:), CS%S_i(i,j,:,:), CS%P_i(i,j,:,:), US, CS%stable_cell(i,j,:) ) if (CS%interior_only) then if (.not. CS%stable_cell(i,j,k_bot(i,j))) zeta_bot(i,j) = -1. ! set values in the surface and bottom boundary layer to false. @@ -438,7 +438,7 @@ subroutine neutral_diffusion_calc_coeffs(G, GV, US, h, T, S, CS) CS%uPoL(I,j,:), CS%uPoR(I,j,:), CS%uKoL(I,j,:), CS%uKoR(I,j,:), CS%uhEff(I,j,:), & k_bot(I,j), k_bot(I+1,j), 1.-zeta_bot(I,j), 1.-zeta_bot(I+1,j)) else - call find_neutral_surface_positions_discontinuous(CS, G%ke, & + call find_neutral_surface_positions_discontinuous(CS, US, G%ke, & CS%P_i(i,j,:,:), h(i,j,:), CS%T_i(i,j,:,:), CS%S_i(i,j,:,:), CS%ppoly_coeffs_T(i,j,:,:), & CS%ppoly_coeffs_S(i,j,:,:),CS%stable_cell(i,j,:), & CS%P_i(i+1,j,:,:), h(i+1,j,:), CS%T_i(i+1,j,:,:), CS%S_i(i+1,j,:,:), CS%ppoly_coeffs_T(i+1,j,:,:), & @@ -456,10 +456,10 @@ subroutine neutral_diffusion_calc_coeffs(G, GV, US, h, T, S, CS) call find_neutral_surface_positions_continuous(G%ke, & CS%Pint(i,j,:), CS%Tint(i,j,:), CS%Sint(i,j,:), CS%dRdT(i,j,:), CS%dRdS(i,j,:), & CS%Pint(i,j+1,:), CS%Tint(i,j+1,:), CS%Sint(i,j+1,:), CS%dRdT(i,j+1,:), CS%dRdS(i,j+1,:), & - CS%vPoL(i,J,:), CS%vPoR(i,J,:), CS%vKoL(i,J,:), CS%vKoR(i,J,:), CS%vhEff(i,J,:), & + CS%vPoL(i,J,:), CS%vPoR(i,J,:), CS%vKoL(i,J,:), CS%vKoR(i,J,:), CS%vhEff(i,J,:), & k_bot(i,J), k_bot(i,J+1), 1.-zeta_bot(i,J), 1.-zeta_bot(i,J+1)) else - call find_neutral_surface_positions_discontinuous(CS, G%ke, & + call find_neutral_surface_positions_discontinuous(CS, US, G%ke, & CS%P_i(i,j,:,:), h(i,j,:), CS%T_i(i,j,:,:), CS%S_i(i,j,:,:), CS%ppoly_coeffs_T(i,j,:,:), & CS%ppoly_coeffs_S(i,j,:,:),CS%stable_cell(i,j,:), & CS%P_i(i,j+1,:,:), h(i,j+1,:), CS%T_i(i,j+1,:,:), CS%S_i(i,j+1,:,:), CS%ppoly_coeffs_T(i,j+1,:,:), & @@ -472,8 +472,8 @@ subroutine neutral_diffusion_calc_coeffs(G, GV, US, h, T, S, CS) ! 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 spanned by - ! adjacent neutral surfaces. + ! calculates hEff from the nondimensional fraction of the layer spanned by adjacent neutral + ! surfaces, so hEff is already in thickness units. 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 @@ -906,23 +906,24 @@ end function fvlsq_slope subroutine find_neutral_surface_positions_continuous(nk, Pl, Tl, Sl, dRdTl, dRdSl, Pr, Tr, Sr, & dRdTr, dRdSr, PoL, PoR, KoL, KoR, hEff, bl_kl, bl_kr, bl_zl, bl_zr) 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) :: Pl !< Left-column interface pressure [R L2 T-2 ~> Pa] or other units real, dimension(nk+1), intent(in) :: Tl !< Left-column interface potential temperature [degC] real, dimension(nk+1), intent(in) :: Sl !< Left-column interface salinity [ppt] - real, dimension(nk+1), intent(in) :: dRdTl !< Left-column dRho/dT [kg m-3 degC-1] - real, dimension(nk+1), intent(in) :: dRdSl !< Left-column dRho/dS [kg m-3 ppt-1] - real, dimension(nk+1), intent(in) :: Pr !< Right-column interface pressure [Pa] + real, dimension(nk+1), intent(in) :: dRdTl !< Left-column dRho/dT [R degC-1 ~> kg m-3 degC-1] + real, dimension(nk+1), intent(in) :: dRdSl !< Left-column dRho/dS [R ppt-1 ~> kg m-3 ppt-1] + real, dimension(nk+1), intent(in) :: Pr !< Right-column interface pressure [R L2 T-2 ~> Pa] or other units real, dimension(nk+1), intent(in) :: Tr !< Right-column interface potential temperature [degC] real, dimension(nk+1), intent(in) :: Sr !< Right-column interface salinity [ppt] - real, dimension(nk+1), intent(in) :: dRdTr !< Left-column dRho/dT [kg m-3 degC-1] - real, dimension(nk+1), intent(in) :: dRdSr !< Left-column dRho/dS [kg m-3 ppt-1] + real, dimension(nk+1), intent(in) :: dRdTr !< Left-column dRho/dT [R degC-1 ~> kg m-3 degC-1] + real, dimension(nk+1), intent(in) :: dRdSr !< Left-column dRho/dS [R ppt-1 ~> kg m-3 ppt-1] 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] + real, dimension(2*nk+1), intent(inout) :: hEff !< Effective thickness between two neutral surfaces + !! [R L2 T-2 ~> Pa] or other units following Pl and Pr. integer, optional, intent(in) :: bl_kl !< Layer index of the boundary layer (left) integer, optional, intent(in) :: bl_kr !< Layer index of the boundary layer (right) real, optional, intent(in) :: bl_zl !< Nondimensional position of the boundary layer (left) @@ -933,14 +934,15 @@ subroutine find_neutral_surface_positions_continuous(nk, Pl, Tl, Sl, dRdTl, dRdS integer :: k_surface ! Index of neutral surface integer :: kl ! Index of left interface integer :: kr ! Index of right interface - real :: dRdT, dRdS ! dRho/dT and dRho/dS for the neutral surface + real :: dRdT, dRdS ! dRho/dT [kg m-3 degC-1] and dRho/dS [kg m-3 ppt-1] for the neutral surface logical :: searching_left_column ! True if searching for the position of a right interface in the left column logical :: searching_right_column ! True if searching for the position of a left interface in the right column logical :: reached_bottom ! True if one of the bottom-most interfaces has been used as the target integer :: krm1, klm1 - real :: dRho, dRhoTop, dRhoBot, hL, hR - integer :: lastK_left, lastK_right - real :: lastP_left, lastP_right + real :: dRho, dRhoTop, dRhoBot ! Potential density differences at various points [R ~> kg m-3] + real :: hL, hR ! Pressure thicknesses [R L2 T-2 ~> Pa] + integer :: lastK_left, lastK_right ! Layers used during the last iteration + real :: lastP_left, lastP_right ! Fractional positions during the last iteration [nondim] logical :: interior_limit ns = 2*nk+2 @@ -1003,7 +1005,7 @@ subroutine find_neutral_surface_positions_continuous(nk, Pl, Tl, Sl, dRdTl, dRdS PoL(k_surface) = 1. else ! Linearly interpolate for the position between Pl(kl-1) and Pl(kl) where the density difference - ! between right and left is zero. + ! between right and left is zero. The Pl here are only used to handle massless layers. PoL(k_surface) = interpolate_for_nondim_position( dRhoTop, Pl(klm1), dRhoBot, Pl(klm1+1) ) endif if (PoL(k_surface)>=1. .and. klm1= is really ==, when PoL==1 we point to the bottom of the cell @@ -1032,11 +1034,11 @@ subroutine find_neutral_surface_positions_continuous(nk, Pl, Tl, Sl, dRdTl, dRdS elseif (searching_right_column) then ! Interpolate for the neutral surface position within the right column, layer krm1 ! Potential density difference, rho(kr-1) - rho(kl) (should be negative) - dRhoTop = 0.5 * ( ( dRdTr(krm1) + dRdTl(kl) ) * ( Tr(krm1) - Tl(kl) ) & - + ( dRdSr(krm1) + dRdSl(kl) ) * ( Sr(krm1) - Sl(kl) ) ) + dRhoTop = 0.5 * ( ( dRdTr(krm1) + dRdTl(kl) ) * ( Tr(krm1) - Tl(kl) ) + & + ( dRdSr(krm1) + dRdSl(kl) ) * ( Sr(krm1) - Sl(kl) ) ) ! Potential density difference, rho(kr) - rho(kl) (will be positive) - dRhoBot = 0.5 * ( ( dRdTr(krm1+1) + dRdTl(kl) ) * ( Tr(krm1+1) - Tl(kl) ) & - + ( dRdSr(krm1+1) + dRdSl(kl) ) * ( Sr(krm1+1) - Sl(kl) ) ) + dRhoBot = 0.5 * ( ( dRdTr(krm1+1) + dRdTl(kl) ) * ( Tr(krm1+1) - Tl(kl) ) + & + ( dRdSr(krm1+1) + dRdSl(kl) ) * ( Sr(krm1+1) - Sl(kl) ) ) ! Because we are looking right, the left surface, kl, is lighter than krm1+1 and should be denser than krm1 ! unless we are still at the top of the right column (kr=1) @@ -1046,7 +1048,7 @@ subroutine find_neutral_surface_positions_continuous(nk, Pl, Tl, Sl, dRdTl, dRdS PoR(k_surface) = 1. else ! Linearly interpolate for the position between Pr(kr-1) and Pr(kr) where the density difference - ! between right and left is zero. + ! between right and left is zero. The Pr here are only used to handle massless layers. PoR(k_surface) = interpolate_for_nondim_position( dRhoTop, Pr(krm1), dRhoBot, Pr(krm1+1) ) endif if (PoR(k_surface)>=1. .and. krm1= is really ==, when PoR==1 we point to the bottom of the cell @@ -1108,21 +1110,25 @@ subroutine find_neutral_surface_positions_continuous(nk, Pl, Tl, Sl, dRdTl, dRdS enddo neutral_surfaces end subroutine find_neutral_surface_positions_continuous + !> Returns the non-dimensional position between Pneg and Ppos where the !! interpolated density difference equals zero. !! The result is always bounded to be between 0 and 1. real function interpolate_for_nondim_position(dRhoNeg, Pneg, dRhoPos, Ppos) - real, intent(in) :: dRhoNeg !< Negative density difference - real, intent(in) :: Pneg !< Position of negative density difference - real, intent(in) :: dRhoPos !< Positive density difference - real, intent(in) :: Ppos !< Position of positive density difference + real, intent(in) :: dRhoNeg !< Negative density difference [R ~> kg m-3] + real, intent(in) :: Pneg !< Position of negative density difference [R L2 T-2 ~> Pa] or [nondim] + real, intent(in) :: dRhoPos !< Positive density difference [R ~> kg m-3] + real, intent(in) :: Ppos !< Position of positive density difference [R L2 T-2 ~> Pa] or [nondim] - if (PposdRhoPos) then - write(0,*) 'dRhoNeg, Pneg, dRhoPos, Ppos=',dRhoNeg, Pneg, dRhoPos, Ppos + character(len=120) :: mesg + + if (Ppos < Pneg) then + call MOM_error(FATAL, 'interpolate_for_nondim_position: Houston, we have a problem! PposdRhoPos) then - stop 'interpolate_for_nondim_position: Houston, we have a problem! dRhoNeg>dRhoPos' + write(mesg,*) 'dRhoNeg, Pneg, dRhoPos, Ppos=', dRhoNeg, Pneg, dRhoPos, Ppos + call MOM_error(WARNING, 'interpolate_for_nondim_position: '//trim(mesg)) + elseif (dRhoNeg>dRhoPos) then !### Does this test belong here? + call MOM_error(FATAL, 'interpolate_for_nondim_position: Houston, we have a problem! dRhoNeg>dRhoPos') endif if (Ppos<=Pneg) then ! Handle vanished or inverted layers interpolate_for_nondim_position = 0.5 @@ -1140,42 +1146,46 @@ real function interpolate_for_nondim_position(dRhoNeg, Pneg, dRhoPos, Ppos) 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' + call MOM_error(FATAL, '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' + call MOM_error(FATAL, 'interpolate_for_nondim_position: Houston, we have a problem! Pint > Ppos') end function interpolate_for_nondim_position !> Higher order version of find_neutral_surface_positions. Returns positions within left/right columns !! of combined interfaces using intracell reconstructions of T/S. Note that the polynomial reconstrcutions !! of T and S are optional to aid with unit testing, but will always be passed otherwise -subroutine find_neutral_surface_positions_discontinuous(CS, nk, Pres_l, hcol_l, Tl, Sl, ppoly_T_l, ppoly_S_l, stable_l,& - Pres_r, hcol_r, Tr, Sr, ppoly_T_r, ppoly_S_r, stable_r,& - PoL, PoR, KoL, KoR, hEff, zeta_bot_L, zeta_bot_R, & - k_bot_L, k_bot_R, hard_fail_heff) +subroutine find_neutral_surface_positions_discontinuous(CS, US, nk, & + Pres_l, hcol_l, Tl, Sl, ppoly_T_l, ppoly_S_l, stable_l, & + Pres_r, hcol_r, Tr, Sr, ppoly_T_r, ppoly_S_r, stable_r, & + PoL, PoR, KoL, KoR, hEff, zeta_bot_L, zeta_bot_R, k_bot_L, k_bot_R, hard_fail_heff) type(neutral_diffusion_CS), intent(inout) :: CS !< Neutral diffusion control structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type integer, intent(in) :: nk !< Number of levels - real, dimension(nk,2), intent(in) :: Pres_l !< Left-column interface pressure (Pa) - real, dimension(nk), intent(in) :: hcol_l !< Left-column layer thicknesses - real, dimension(nk,2), intent(in) :: Tl !< Left-column top interface potential temperature (degC) - real, dimension(nk,2), intent(in) :: Sl !< Left-column top interface salinity (ppt) - real, dimension(:,:), intent(in) :: ppoly_T_l !< Left-column coefficients of T reconstruction - real, dimension(:,:), intent(in) :: ppoly_S_l !< Left-column coefficients of S reconstruction - logical, dimension(nk), intent(in) :: stable_l !< Left-column, top interface dRho/dS (kg/m3/ppt) - real, dimension(nk,2), intent(in) :: Pres_r !< Right-column interface pressure (Pa) - real, dimension(nk), intent(in) :: hcol_r !< Left-column layer thicknesses - real, dimension(nk,2), intent(in) :: Tr !< Right-column top interface potential temperature (degC) - real, dimension(nk,2), intent(in) :: Sr !< Right-column top interface salinity (ppt) - real, dimension(:,:), intent(in) :: ppoly_T_r !< Right-column coefficients of T reconstruction - real, dimension(:,:), intent(in) :: ppoly_S_r !< Right-column coefficients of S reconstruction - logical, dimension(nk), intent(in) :: stable_r !< Left-column, top interface dRho/dS (kg/m3/ppt) + real, dimension(nk,2), intent(in) :: Pres_l !< Left-column interface pressure [R L2 T-2 ~> Pa] + real, dimension(nk), intent(in) :: hcol_l !< Left-column layer thicknesses [H ~> m or kg m-2] + !! or other units + real, dimension(nk,2), intent(in) :: Tl !< Left-column top interface potential temperature [degC] + real, dimension(nk,2), intent(in) :: Sl !< Left-column top interface salinity [ppt] + real, dimension(:,:), intent(in) :: ppoly_T_l !< Left-column coefficients of T reconstruction [degC] + real, dimension(:,:), intent(in) :: ppoly_S_l !< Left-column coefficients of S reconstruction [ppt] + logical, dimension(nk), intent(in) :: stable_l !< True where the left-column is stable + real, dimension(nk,2), intent(in) :: Pres_r !< Right-column interface pressure [R L2 T-2 ~> Pa] + real, dimension(nk), intent(in) :: hcol_r !< Left-column layer thicknesses [H ~> m or kg m-2] + !! or other units + real, dimension(nk,2), intent(in) :: Tr !< Right-column top interface potential temperature [degC] + real, dimension(nk,2), intent(in) :: Sr !< Right-column top interface salinity [ppt] + real, dimension(:,:), intent(in) :: ppoly_T_r !< Right-column coefficients of T reconstruction [degC] + real, dimension(:,:), intent(in) :: ppoly_S_r !< Right-column coefficients of S reconstruction [ppt] + logical, dimension(nk), intent(in) :: stable_r !< True where the right-column is stable real, dimension(4*nk), intent(inout) :: PoL !< Fractional position of neutral surface within - !! layer KoL of left column + !! layer KoL of left column [nondim] real, dimension(4*nk), intent(inout) :: PoR !< Fractional position of neutral surface within - !! layer KoR of right column + !! layer KoR of right column [nondim] 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(4*nk-1), intent(inout) :: hEff !< Effective thickness between two neutral surfaces + !! [H ~> m or kg m-2] or other units taken from hcol_l real, optional, intent(in) :: zeta_bot_L!< Non-dimensional distance to where the boundary layer !! intersetcs the cell (left) [nondim] real, optional, intent(in) :: zeta_bot_R!< Non-dimensional distance to where the boundary layer @@ -1194,17 +1204,13 @@ subroutine find_neutral_surface_positions_discontinuous(CS, nk, Pres_l, hcol_l, logical :: searching_right_column ! True if searching for the position of a left interface in the right column logical :: reached_bottom ! True if one of the bottom-most interfaces has been used as the target logical :: search_layer - logical :: fail_heff ! By default, - real :: dRho, dRhoTop, dRhoBot, hL, hR - real :: z0, pos - real :: dRdT_from_top, dRdS_from_top ! Density derivatives at the searched from interface - real :: dRdT_from_bot, dRdS_from_bot ! Density derivatives at the searched from interface - real :: dRdT_to_top, dRdS_to_top ! Density derivatives at the interfaces being searched - real :: dRdT_to_bot, dRdS_to_bot ! Density derivatives at the interfaces being searched - real :: T_ref, S_ref, P_ref, P_top, P_bot - real :: lastP_left, lastP_right - integer :: k_init_L, k_init_R ! Starting indices layers for left and right - real :: p_init_L, p_init_R ! Starting positions for left and right + logical :: fail_heff ! Fail if negative thickness are encountered. By default this + ! is true, but it can take its value from hard_fail_heff. + real :: dRho ! A density difference between columns [R ~> kg m-3] + real :: hL, hR ! Left and right layer thicknesses [H ~> m or kg m-2] or units from hcol_l + real :: lastP_left, lastP_right ! Previous positions for left and right [nondim] + integer :: k_init_L, k_init_R ! Starting indices layers for left and right + real :: p_init_L, p_init_R ! Starting positions for left and right [nondim] ! Initialize variables for the search ns = 4*nk ki_right = 1 @@ -1272,11 +1278,11 @@ subroutine find_neutral_surface_positions_discontinuous(CS, nk, Pres_l, hcol_l, ! For convenience, the left column uses the searched "from" interface variables, and the right column ! uses the searched 'to'. These will get reset in subsequent calc_delta_rho calls - call calc_delta_rho_and_derivs(CS, & - Tr(kl_right, ki_right), Sr(kl_right, ki_right), Pres_r(kl_right,ki_right), & - Tl(kl_left, ki_left), Sl(kl_left, ki_left) , Pres_l(kl_left,ki_left), & + call calc_delta_rho_and_derivs(CS, US, & + Tr(kl_right, ki_right), Sr(kl_right, ki_right), Pres_r(kl_right,ki_right), & + Tl(kl_left, ki_left), Sl(kl_left, ki_left) , Pres_l(kl_left,ki_left), & dRho) - if (CS%debug) write(*,'(A,I2,A,E12.4,A,I2,A,I2,A,I2,A,I2)') "k_surface=",k_surface," dRho=",dRho, & + if (CS%debug) write(*,'(A,I2,A,E12.4,A,I2,A,I2,A,I2,A,I2)') "k_surface=",k_surface," dRho=",US%R_to_kg_m3*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 @@ -1300,7 +1306,7 @@ subroutine find_neutral_surface_positions_discontinuous(CS, nk, Pres_l, hcol_l, ! Position of the right interface is known and all quantities are fixed PoR(k_surface) = ki_right - 1. KoR(k_surface) = kl_right - PoL(k_surface) = search_other_column(CS, k_surface, lastP_left, & + PoL(k_surface) = search_other_column(CS, US, k_surface, lastP_left, & Tr(kl_right, ki_right), Sr(kl_right, ki_right), Pres_r(kl_right, ki_right), & Tl(kl_left,1), Sl(kl_left,1), Pres_l(kl_left,1), & Tl(kl_left,2), Sl(kl_left,2), Pres_l(kl_left,2), & @@ -1323,7 +1329,7 @@ subroutine find_neutral_surface_positions_discontinuous(CS, nk, Pres_l, hcol_l, ! Position of the right interface is known and all quantities are fixed PoL(k_surface) = ki_left - 1. KoL(k_surface) = kl_left - PoR(k_surface) = search_other_column(CS, k_surface, lastP_right, & + PoR(k_surface) = search_other_column(CS, US, k_surface, lastP_right, & Tl(kl_left, ki_left), Sl(kl_left, ki_left), Pres_l(kl_left, ki_left), & Tr(kl_right,1), Sr(kl_right,1), Pres_r(kl_right,1), & Tr(kl_right,2), Sr(kl_right,2), Pres_r(kl_right,2), & @@ -1365,15 +1371,15 @@ subroutine find_neutral_surface_positions_discontinuous(CS, nk, Pres_l, hcol_l, endif endif elseif ( hL + hR == 0. ) then - hEff(k_surface-1) = 0. + hEff(k_surface-1) = 0. else - hEff(k_surface-1) = 2. * ( (hL * hR) / ( hL + hR ) )! Harmonic mean - if ( KoL(k_surface) /= KoL(k_surface-1) ) then - call MOM_error(FATAL,"Neutral sublayer spans multiple layers") - endif - if ( KoR(k_surface) /= KoR(k_surface-1) ) then - call MOM_error(FATAL,"Neutral sublayer spans multiple layers") - endif + hEff(k_surface-1) = 2. * ( (hL * hR) / ( hL + hR ) )! Harmonic mean + if ( KoL(k_surface) /= KoL(k_surface-1) ) then + call MOM_error(FATAL,"Neutral sublayer spans multiple layers") + endif + if ( KoR(k_surface) /= KoR(k_surface-1) ) then + call MOM_error(FATAL,"Neutral sublayer spans multiple layers") + endif endif else hEff(k_surface-1) = 0. @@ -1383,56 +1389,59 @@ subroutine find_neutral_surface_positions_discontinuous(CS, nk, Pres_l, hcol_l, end subroutine find_neutral_surface_positions_discontinuous !> Sweep down through the column and mark as stable if the bottom interface of a cell is denser than the top -subroutine mark_unstable_cells(CS, nk, T, S, P, stable_cell) +subroutine mark_unstable_cells(CS, nk, T, S, P, US, stable_cell) type(neutral_diffusion_CS), intent(inout) :: CS !< Neutral diffusion control structure integer, intent(in) :: nk !< Number of levels in a column - real, dimension(nk,2), intent(in) :: T !< Temperature at interfaces - real, dimension(nk,2), intent(in) :: S !< Salinity at interfaces - real, dimension(nk,2), intent(in) :: P !< Pressure at interfaces + real, dimension(nk,2), intent(in) :: T !< Temperature at interfaces [degC] + real, dimension(nk,2), intent(in) :: S !< Salinity at interfaces [ppt] + real, dimension(nk,2), intent(in) :: P !< Pressure at interfaces [R L2 T-2 ~> Pa] + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type logical, dimension(nk), intent( out) :: stable_cell !< True if this cell is unstably stratified integer :: k, first_stable, prev_stable - real :: delta_rho + real :: delta_rho ! A density difference [R ~> kg m-3] do k = 1,nk - call calc_delta_rho_and_derivs( CS, T(k,2), S(k,2), max(P(k,2),CS%ref_pres), & - T(k,1), S(k,1), max(P(k,1),CS%ref_pres), delta_rho ) - stable_cell(k) = delta_rho > 0. + call calc_delta_rho_and_derivs( CS, US, T(k,2), S(k,2), max(P(k,2), CS%ref_pres), & + T(k,1), S(k,1), max(P(k,1), CS%ref_pres), delta_rho ) + stable_cell(k) = (delta_rho > 0.) enddo end subroutine mark_unstable_cells !> Searches the "other" (searched) column for the position of the neutral surface -real function search_other_column(CS, ksurf, pos_last, T_from, S_from, P_from, T_top, S_top, P_top, & +real function search_other_column(CS, US, ksurf, pos_last, T_from, S_from, P_from, T_top, S_top, P_top, & T_bot, S_bot, P_bot, T_poly, S_poly ) result(pos) type(neutral_diffusion_CS), intent(in ) :: CS !< Neutral diffusion control structure + type(unit_scale_type), intent(in ) :: US !< A dimensional unit scaling type integer, intent(in ) :: ksurf !< Current index of neutral surface real, intent(in ) :: pos_last !< Last position within the current layer, used as the lower - !! bound in the rootfinding algorithm - real, intent(in ) :: T_from !< Temperature at the searched from interface - real, intent(in ) :: S_from !< Salinity at the searched from interface - real, intent(in ) :: P_from !< Pressure at the searched from interface - real, intent(in ) :: T_top !< Temperature at the searched to top interface - real, intent(in ) :: S_top !< Salinity at the searched to top interface - real, intent(in ) :: P_top !< Pressure at the searched to top interface - real, intent(in ) :: T_bot !< Temperature at the searched to bottom interface - real, intent(in ) :: S_bot !< Salinity at the searched to bottom interface - real, intent(in ) :: P_bot !< Pressure at the searched to bottom interface - real, dimension(:), intent(in ) :: T_poly !< Temperature polynomial reconstruction coefficients - real, dimension(:), intent(in ) :: S_poly !< Salinity polynomial reconstruction coefficients + !! bound in the root finding algorithm [nondim] + real, intent(in ) :: T_from !< Temperature at the searched from interface [degC] + real, intent(in ) :: S_from !< Salinity at the searched from interface [ppt] + real, intent(in ) :: P_from !< Pressure at the searched from interface [R L2 T-2 ~> Pa] + real, intent(in ) :: T_top !< Temperature at the searched to top interface [degC] + real, intent(in ) :: S_top !< Salinity at the searched to top interface [ppt] + real, intent(in ) :: P_top !< Pressure at the searched to top interface [R L2 T-2 ~> Pa] + !! interface [R L2 T-2 ~> Pa] + real, intent(in ) :: T_bot !< Temperature at the searched to bottom interface [degC] + real, intent(in ) :: S_bot !< Salinity at the searched to bottom interface [ppt] + real, intent(in ) :: P_bot !< Pressure at the searched to bottom + !! interface [R L2 T-2 ~> Pa] + real, dimension(:), intent(in ) :: T_poly !< Temperature polynomial reconstruction coefficients [degC] + real, dimension(:), intent(in ) :: S_poly !< Salinity polynomial reconstruction coefficients [ppt] ! Local variables - real :: dRhotop, dRhobot - real :: dRdT_top, dRdS_top, dRdT_bot, dRdS_bot - real :: dRdT_from, dRdS_from - real :: P_mid + real :: dRhotop, dRhobot ! Density differences [R ~> kg m-3] + real :: dRdT_top, dRdT_bot, dRdT_from ! Partial derivatives of density with temperature [R degC-1 ~> kg m-3 degC-1] + real :: dRdS_top, dRdS_bot, dRdS_from ! Partial derivatives of density with salinity [R ppt-1 ~> kg m-3 ppt-1] ! Calculate the differencei in density at the tops or the bottom if (CS%neutral_pos_method == 1 .or. CS%neutral_pos_method == 3) then - call calc_delta_rho_and_derivs(CS, T_top, S_top, P_top, T_from, S_from, P_from, dRhoTop) - call calc_delta_rho_and_derivs(CS, T_bot, S_bot, P_bot, T_from, S_from, P_from, dRhoBot) + call calc_delta_rho_and_derivs(CS, US, T_top, S_top, P_top, T_from, S_from, P_from, dRhoTop) + call calc_delta_rho_and_derivs(CS, US, T_bot, S_bot, P_bot, T_from, S_from, P_from, dRhoBot) elseif (CS%neutral_pos_method == 2) then - call calc_delta_rho_and_derivs(CS, T_top, S_top, P_top, T_from, S_from, P_from, dRhoTop, & + call calc_delta_rho_and_derivs(CS, US, T_top, S_top, P_top, T_from, S_from, P_from, dRhoTop, & dRdT_top, dRdS_top, dRdT_from, dRdS_from) - call calc_delta_rho_and_derivs(CS, T_bot, S_bot, P_bot, T_from, S_from, P_from, dRhoBot, & + call calc_delta_rho_and_derivs(CS, US, T_bot, S_bot, P_bot, T_from, S_from, P_from, dRhoBot, & dRdT_bot, dRdS_bot, dRdT_from, dRdS_from) endif @@ -1461,11 +1470,10 @@ real function search_other_column(CS, ksurf, pos_last, T_from, S_from, P_from, T ! For the 'Linear' case of finding the neutral position, the fromerence pressure to use is the average ! of the midpoint of the layer being searched and the interface being searched from elseif (CS%neutral_pos_method == 2) then - pos = find_neutral_pos_linear( CS, pos_last, T_from, S_from, P_from, dRdT_from, dRdS_from, & - P_top, dRdT_top, dRdS_top, & - P_bot, dRdT_bot, dRdS_bot, T_poly, S_poly ) + pos = find_neutral_pos_linear( CS, pos_last, T_from, S_from, dRdT_from, dRdS_from, & + dRdT_top, dRdS_top, dRdT_bot, dRdS_bot, T_poly, S_poly ) elseif (CS%neutral_pos_method == 3) then - pos = find_neutral_pos_full( CS, pos_last, T_from, S_from, P_from, P_top, P_bot, T_poly, S_poly) + pos = find_neutral_pos_full( CS, US, pos_last, T_from, S_from, P_from, P_top, P_bot, T_poly, S_poly) endif end function search_other_column @@ -1505,43 +1513,52 @@ end subroutine increment_interface !! interval [0,1], a bisection step would be taken instead. Also this linearization of alpha, beta means that second !! derivatives of the EOS are not needed. Note that delta in variable names below refers to horizontal differences and !! 'd' refers to vertical differences -function find_neutral_pos_linear( CS, z0, T_ref, S_ref, P_ref, dRdT_ref, dRdS_ref, & - P_top, dRdT_top, dRdS_top, & - P_bot, dRdT_bot, dRdS_bot, ppoly_T, ppoly_S ) result( z ) +function find_neutral_pos_linear( CS, z0, T_ref, S_ref, dRdT_ref, dRdS_ref, & + dRdT_top, dRdS_top, dRdT_bot, dRdS_bot, ppoly_T, ppoly_S ) result( z ) type(neutral_diffusion_CS),intent(in) :: CS !< Control structure with parameters for this module - real, intent(in) :: z0 !< Lower bound of position, also serves as the initial guess - real, intent(in) :: T_ref !< Temperature at the searched from interface - real, intent(in) :: S_ref !< Salinity at the searched from interface - real, intent(in) :: P_ref !< Pressure at the searched from interface + real, intent(in) :: z0 !< Lower bound of position, also serves as the + !! initial guess [nondim] + real, intent(in) :: T_ref !< Temperature at the searched from interface [degC] + real, intent(in) :: S_ref !< Salinity at the searched from interface [ppt] real, intent(in) :: dRdT_ref !< dRho/dT at the searched from interface + !! [R degC-1 ~> kg m-3 degC-1] real, intent(in) :: dRdS_ref !< dRho/dS at the searched from interface - real, intent(in) :: P_top !< Pressure at top of layer being searched + !! [R ppt-1 ~> kg m-3 ppt-1] real, intent(in) :: dRdT_top !< dRho/dT at top of layer being searched + !! [R degC-1 ~> kg m-3 degC-1] real, intent(in) :: dRdS_top !< dRho/dS at top of layer being searched - real, intent(in) :: P_bot !< Pressure at bottom of layer being searched + !! [R ppt-1 ~> kg m-3 ppt-1] real, intent(in) :: dRdT_bot !< dRho/dT at bottom of layer being searched + !! [R degC-1 ~> kg m-3 degC-1] real, intent(in) :: dRdS_bot !< dRho/dS at bottom of layer being searched + !! [R ppt-1 ~> kg m-3 ppt-1] real, dimension(:), intent(in) :: ppoly_T !< Coefficients of the polynomial reconstruction of T within - !! the layer to be searched. - real, dimension(:), intent(in) :: ppoly_S !< Coefficients of the polynomial reconstruction of T within - !! the layer to be searched. - real :: z !< Position where drho = 0 + !! the layer to be searched [degC]. + real, dimension(:), intent(in) :: ppoly_S !< Coefficients of the polynomial reconstruction of S within + !! the layer to be searched [ppt]. + real :: z !< Position where drho = 0 [nondim] ! Local variables - real :: dRdT_diff, dRdS_diff - real :: drho, drho_dz, dRdT_z, dRdS_z, T_z, S_z, deltaT, deltaS, deltaP, dT_dz, dS_dz - real :: drho_min, drho_max, ztest, zmin, zmax, dRdT_sum, dRdS_sum, dz, P_z, dP_dz - real :: a1, a2 + real :: dRdT_diff ! Difference in the partial derivative of density with temperature across the + ! layer [R degC-1 ~> kg m-3 degC-1] + real :: dRdS_diff ! Difference in the partial derivative of density with salinity across the + ! layer [R ppt-1 ~> kg m-3 ppt-1] + real :: drho, drho_dz ! Density anomaly and its derivative with fracitonal position [R ~> kg m-3] + real :: dRdT_z ! Partial derivative of density with temperature at a point [R degC-1 ~> kg m-3 degC-1] + real :: dRdS_z ! Partial derivative of density with salinity at a point [R ppt-1 ~> kg m-3 ppt-1] + real :: T_z, dT_dz ! Temperature at a point and its derivative with fractional position [degC] + real :: S_z, dS_dz ! Salinity at a point and its derivative with fractional position [ppt] + real :: drho_min, drho_max ! Bounds on density differences [R ~> kg m-3] + real :: ztest, zmin, zmax ! Fractional positions in the cell [nondim] + real :: dz ! Change in position in the cell [nondim] + real :: a1, a2 ! Fractional weights of the top and bottom values [nondim] integer :: iter integer :: nterm - real :: T_top, T_bot, S_top, S_bot nterm = SIZE(ppoly_T) ! Position independent quantities dRdT_diff = dRdT_bot - dRdT_top dRdS_diff = dRdS_bot - dRdS_top - ! Assume a linear increase in pressure from top and bottom of the cell - dP_dz = P_bot - P_top ! Initial starting drho (used for bisection) zmin = z0 ! Lower bounding interval zmax = 1. ! Maximum bounding interval (bottom of layer) @@ -1551,14 +1568,11 @@ function find_neutral_pos_linear( CS, z0, T_ref, S_ref, P_ref, dRdT_ref, dRdS_r S_z = evaluation_polynomial( ppoly_S, nterm, zmin ) dRdT_z = a1*dRdT_top + a2*dRdT_bot dRdS_z = a1*dRdS_top + a2*dRdS_bot - P_z = a1*P_top + a2*P_bot - drho_min = delta_rho_from_derivs(T_z, S_z, P_z, dRdT_z, dRdS_z, & - T_ref, S_ref, P_ref, dRdT_ref, dRdS_ref) + drho_min = 0.5*((dRdT_z+dRdT_ref)*(T_z-T_ref) + (dRdS_z+dRdS_ref)*(S_z-S_ref)) T_z = evaluation_polynomial( ppoly_T, nterm, 1. ) S_z = evaluation_polynomial( ppoly_S, nterm, 1. ) - drho_max = delta_rho_from_derivs(T_z, S_z, P_bot, dRdT_bot, dRdS_bot, & - T_ref, S_ref, P_ref, dRdT_ref, dRdS_ref) + drho_max = 0.5*((dRdT_bot+dRdT_ref)*(T_z-T_ref) + (dRdS_bot+dRdS_ref)*(S_z-S_ref)) if (drho_min >= 0.) then z = z0 @@ -1581,14 +1595,7 @@ function find_neutral_pos_linear( CS, z0, T_ref, S_ref, P_ref, dRdT_ref, dRdS_r dRdS_z = a1*dRdS_top + a2*dRdS_bot T_z = evaluation_polynomial( ppoly_T, nterm, z ) S_z = evaluation_polynomial( ppoly_S, nterm, z ) - P_z = a1*P_top + a2*P_bot - deltaT = T_z - T_ref - deltaS = S_z - S_ref - deltaP = P_z - P_ref - dRdT_sum = dRdT_ref + dRdT_z - dRdS_sum = dRdS_ref + dRdS_z - drho = delta_rho_from_derivs(T_z, S_z, P_z, dRdT_z, dRdS_z, & - T_ref, S_ref, P_ref, dRdT_ref, dRdS_ref) + drho = 0.5*((dRdT_z+dRdT_ref)*(T_z-T_ref) + (dRdS_z+dRdS_ref)*(S_z-S_ref)) ! Check for convergence if (ABS(drho) <= CS%drho_tol) exit @@ -1604,7 +1611,8 @@ function find_neutral_pos_linear( CS, z0, T_ref, S_ref, P_ref, dRdT_ref, dRdS_r ! Calculate a Newton step dT_dz = first_derivative_polynomial( ppoly_T, nterm, z ) dS_dz = first_derivative_polynomial( ppoly_S, nterm, z ) - drho_dz = 0.5*( (dRdT_diff*deltaT + dRdT_sum*dT_dz) + (dRdS_diff*deltaS + dRdS_sum*dS_dz) ) + drho_dz = 0.5*( (dRdT_diff*(T_z - T_ref) + (dRdT_ref+dRdT_z)*dT_dz) + & + (dRdS_diff*(S_z - S_ref) + (dRdS_ref+dRdS_z)*dS_dz) ) ztest = z - drho/drho_dz ! Take a bisection if z falls out of [zmin,zmax] @@ -1626,43 +1634,48 @@ end function find_neutral_pos_linear !> Use the full equation of state to calculate the difference in locally referenced potential density. The derivatives !! in this case are not trivial to calculate, so instead we use a regula falsi method -function find_neutral_pos_full( CS, z0, T_ref, S_ref, P_ref, P_top, P_bot, ppoly_T, ppoly_S ) result( z ) +function find_neutral_pos_full( CS, US, z0, T_ref, S_ref, P_ref, P_top, P_bot, ppoly_T, ppoly_S ) result( z ) type(neutral_diffusion_CS),intent(in) :: CS !< Control structure with parameters for this module - real, intent(in) :: z0 !< Lower bound of position, also serves as the initial guess - real, intent(in) :: T_ref !< Temperature at the searched from interface - real, intent(in) :: S_ref !< Salinity at the searched from interface - real, intent(in) :: P_ref !< Pressure at the searched from interface - real, intent(in) :: P_top !< Pressure at top of layer being searched - real, intent(in) :: P_bot !< Pressure at bottom of layer being searched + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, intent(in) :: z0 !< Lower bound of position, also serves as the + !! initial guess [nondim] + real, intent(in) :: T_ref !< Temperature at the searched from interface [degC] + real, intent(in) :: S_ref !< Salinity at the searched from interface [ppt] + real, intent(in) :: P_ref !< Pressure at the searched from interface [R L2 T-2 ~> Pa] + real, intent(in) :: P_top !< Pressure at top of layer being searched [R L2 T-2 ~> Pa] + real, intent(in) :: P_bot !< Pressure at bottom of layer being searched [R L2 T-2 ~> Pa] real, dimension(:), intent(in) :: ppoly_T !< Coefficients of the polynomial reconstruction of T within - !! the layer to be searched. + !! the layer to be searched [degC] real, dimension(:), intent(in) :: ppoly_S !< Coefficients of the polynomial reconstruction of T within - !! the layer to be searched. - real :: z !< Position where drho = 0 + !! the layer to be searched [ppt] + real :: z !< Position where drho = 0 [nondim] ! Local variables integer :: iter integer :: nterm - real :: drho_a, drho_b, drho_c - real :: a, b, c, Ta, Tb, Tc, Sa, Sb, Sc, Pa, Pb, Pc + real :: drho_a, drho_b, drho_c ! Density differences [R ~> kg m-3] + real :: a, b, c ! Fractional positions [nondim] + real :: Ta, Tb, Tc ! Temperatures [degC] + real :: Sa, Sb, Sc ! Salinities [ppt] + real :: Pa, Pb, Pc ! Pressures [R L2 T-2 ~> Pa] integer :: side side = 0 ! Set the first two evaluation to the endpoints of the interval - b = z0; c = 1 + b = z0 ; c = 1 nterm = SIZE(ppoly_T) ! Calculate drho at the minimum bound Tb = evaluation_polynomial( ppoly_T, nterm, b ) Sb = evaluation_polynomial( ppoly_S, nterm, b ) Pb = P_top*(1.-b) + P_bot*b - call calc_delta_rho_and_derivs(CS, Tb, Sb, Pb, T_ref, S_ref, P_ref, drho_b) + call calc_delta_rho_and_derivs(CS, US, Tb, Sb, Pb, T_ref, S_ref, P_ref, drho_b) ! Calculate drho at the maximum bound Tc = evaluation_polynomial( ppoly_T, nterm, 1. ) Sc = evaluation_polynomial( ppoly_S, nterm, 1. ) Pc = P_Bot - call calc_delta_rho_and_derivs(CS, Tc, Sc, Pc, T_ref, S_ref, P_ref, drho_c) + call calc_delta_rho_and_derivs(CS, US, Tc, Sc, Pc, T_ref, S_ref, P_ref, drho_c) if (drho_b >= 0.) then z = z0 @@ -1682,7 +1695,7 @@ function find_neutral_pos_full( CS, z0, T_ref, S_ref, P_ref, P_top, P_bot, ppoly Ta = evaluation_polynomial( ppoly_T, nterm, a ) Sa = evaluation_polynomial( ppoly_S, nterm, a ) Pa = P_top*(1.-a) + P_bot*a - call calc_delta_rho_and_derivs(CS, Ta, Sa, Pa, T_ref, S_ref, P_ref, drho_a) + call calc_delta_rho_and_derivs(CS, US, Ta, Sa, Pa, T_ref, S_ref, P_ref, drho_a) if (ABS(drho_a) < CS%drho_tol) then z = a return @@ -1715,23 +1728,27 @@ function find_neutral_pos_full( CS, z0, T_ref, S_ref, P_ref, P_top, P_bot, ppoly end function find_neutral_pos_full !> Calculate the difference in density between two points in a variety of ways -subroutine calc_delta_rho_and_derivs(CS, T1, S1, p1_in, T2, S2, p2_in, drho, & +subroutine calc_delta_rho_and_derivs(CS, US, T1, S1, p1_in, T2, S2, p2_in, drho, & drdt1_out, drds1_out, drdt2_out, drds2_out ) type(neutral_diffusion_CS) :: CS !< Neutral diffusion control structure - real, intent(in ) :: T1 !< Temperature at point 1 - real, intent(in ) :: S1 !< Salinity at point 1 - real, intent(in ) :: p1_in !< Pressure at point 1 - real, intent(in ) :: T2 !< Temperature at point 2 - real, intent(in ) :: S2 !< Salinity at point 2 - real, intent(in ) :: p2_in !< Pressure at point 2 - real, intent( out) :: drho !< Difference in density between the two points - real, optional, intent( out) :: dRdT1_out !< drho_dt at point 1 - real, optional, intent( out) :: dRdS1_out !< drho_ds at point 1 - real, optional, intent( out) :: dRdT2_out !< drho_dt at point 2 - real, optional, intent( out) :: dRdS2_out !< drho_ds at point 2 + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, intent(in ) :: T1 !< Temperature at point 1 [degC] + real, intent(in ) :: S1 !< Salinity at point 1 [ppt] + real, intent(in ) :: p1_in !< Pressure at point 1 [R L2 T-2 ~> Pa] + real, intent(in ) :: T2 !< Temperature at point 2 [degC] + real, intent(in ) :: S2 !< Salinity at point 2 [ppt] + real, intent(in ) :: p2_in !< Pressure at point 2 [R L2 T-2 ~> Pa] + real, intent( out) :: drho !< Difference in density between the two points [R ~> kg m-3] + real, optional, intent( out) :: dRdT1_out !< drho_dt at point 1 [R degC-1 ~> kg m-3 degC-1] + real, optional, intent( out) :: dRdS1_out !< drho_ds at point 1 [R ppt-1 ~> kg m-3 ppt-1] + real, optional, intent( out) :: dRdT2_out !< drho_dt at point 2 [R degC-1 ~> kg m-3 degC-1] + real, optional, intent( out) :: dRdS2_out !< drho_ds at point 2 [R ppt-1 ~> kg m-3 ppt-1] ! Local variables - real :: rho1, rho2, p1, p2, pmid - real :: drdt1, drdt2, drds1, drds2, drdp1, drdp2, rho_dummy + real :: rho1, rho2 ! Densities [R ~> kg m-3] + real :: p1, p2, pmid ! Pressures [R L2 T-2 ~> Pa] + real :: drdt1, drdt2 ! Partial derivatives of density with temperature [R degC-1 ~> kg m-3 degC-1] + real :: drds1, drds2 ! Partial derivatives of density with salinity [R ppt-1 ~> kg m-3 ppt-1] + real :: drdp1, drdp2 ! Partial derivatives of density with pressure [T2 L-2 ~> s2 m-2] ! Use the same reference pressure or the in-situ pressure if (CS%ref_pres > 0.) then @@ -1745,20 +1762,20 @@ subroutine calc_delta_rho_and_derivs(CS, T1, S1, p1_in, T2, S2, p2_in, drho, ! Use the full linear equation of state to calculate the difference in density (expensive!) if (TRIM(CS%delta_rho_form) == 'full') then pmid = 0.5 * (p1 + p2) - call calculate_density( T1, S1, pmid, rho1, CS%EOS ) - call calculate_density( T2, S2, pmid, rho2, CS%EOS ) + call calculate_density( T1, S1, pmid, rho1, CS%EOS, US=US ) + call calculate_density( T2, S2, pmid, rho2, CS%EOS, US=US ) drho = rho1 - rho2 ! Use the density derivatives at the average of pressures and the differentces int temperature elseif (TRIM(CS%delta_rho_form) == 'mid_pressure') then pmid = 0.5 * (p1 + p2) if (CS%ref_pres>=0) pmid = CS%ref_pres - call calculate_density_derivs(T1, S1, pmid, drdt1, drds1, CS%EOS) - call calculate_density_derivs(T2, S2, pmid, drdt2, drds2, CS%EOS) - drho = delta_rho_from_derivs( T1, S1, P1, drdt1, drds1, T2, S2, P2, drdt2, drds2) + call calculate_density_derivs(T1, S1, pmid, drdt1, drds1, CS%EOS, US) + call calculate_density_derivs(T2, S2, pmid, drdt2, drds2, CS%EOS, US) + drho = delta_rho_from_derivs( T1, S1, p1, drdt1, drds1, T2, S2, p2, drdt2, drds2) elseif (TRIM(CS%delta_rho_form) == 'local_pressure') then - call calculate_density_derivs(T1, S1, p1, drdt1, drds1, CS%EOS) - call calculate_density_derivs(T2, S2, p2, drdt2, drds2, CS%EOS) - drho = delta_rho_from_derivs( T1, S1, P1, drdt1, drds1, T2, S2, P2, drdt2, drds2) + call calculate_density_derivs(T1, S1, p1, drdt1, drds1, CS%EOS, US) + call calculate_density_derivs(T2, S2, p2, drdt2, drds2, CS%EOS, US) + drho = delta_rho_from_derivs( T1, S1, p1, drdt1, drds1, T2, S2, p2, drdt2, drds2) else call MOM_error(FATAL, "delta_rho_form is not recognized") endif @@ -1776,30 +1793,33 @@ end subroutine calc_delta_rho_and_derivs !! (\gamma^{-1}_1 + \gamma%{-1}_2)*(P_1-P_2) \right] \f$ function delta_rho_from_derivs( T1, S1, P1, dRdT1, dRdS1, & T2, S2, P2, dRdT2, dRdS2 ) result (drho) - real :: T1 !< Temperature at point 1 - real :: S1 !< Salinity at point 1 - real :: P1 !< Pressure at point 1 - real :: dRdT1 !< Pressure at point 1 - real :: dRdS1 !< Pressure at point 1 - real :: T2 !< Temperature at point 2 - real :: S2 !< Salinity at point 2 - real :: P2 !< Pressure at point 2 - real :: dRdT2 !< Pressure at point 2 - real :: dRdS2 !< Pressure at point 2 + real :: T1 !< Temperature at point 1 [degC] + real :: S1 !< Salinity at point 1 [ppt] + real :: P1 !< Pressure at point 1 [R L2 T-2 ~> Pa] + real :: dRdT1 !< The partial derivative of density with temperature at point 1 [R degC-1 ~> kg m-3 degC-1] + real :: dRdS1 !< The partial derivative of density with salinity at point 1 [R ppt-1 ~> kg m-3 ppt-1] + real :: T2 !< Temperature at point 2 [degC] + real :: S2 !< Salinity at point 2 [ppt] + real :: P2 !< Pressure at point 2 [R L2 T-2 ~> Pa] + real :: dRdT2 !< The partial derivative of density with temperature at point 2 [R degC-1 ~> kg m-3 degC-1] + real :: dRdS2 !< The partial derivative of density with salinity at point 2 [R ppt-1 ~> kg m-3 ppt-1] ! Local variables - real :: drho + real :: drho ! The density difference [R ~> kg m-3] drho = 0.5 * ( (dRdT1+dRdT2)*(T1-T2) + (dRdS1+dRdS2)*(S1-S2)) end function delta_rho_from_derivs + !> Converts non-dimensional position within a layer to absolute position (for debugging) -real function absolute_position(n,ns,Pint,Karr,NParr,k_surface) +function absolute_position(n,ns,Pint,Karr,NParr,k_surface) integer, intent(in) :: n !< Number of levels integer, intent(in) :: ns !< Number of neutral surfaces - real, intent(in) :: Pint(n+1) !< Position of interfaces [Pa] + real, intent(in) :: Pint(n+1) !< Position of interfaces [R L2 T-2 ~> Pa] or other units integer, intent(in) :: Karr(ns) !< Index of interface above position - real, intent(in) :: NParr(ns) !< Non-dimensional position within layer Karr(:) + real, intent(in) :: NParr(ns) !< Non-dimensional position within layer Karr(:) [nondim] integer, intent(in) :: k_surface !< k-interface to query + real :: absolute_position !< The absolute position of a location [R L2 T-2 ~> Pa] + !! or other units following Pint ! Local variables integer :: k @@ -1811,13 +1831,14 @@ end function absolute_position !> Converts non-dimensional positions within layers to absolute positions (for debugging) function absolute_positions(n,ns,Pint,Karr,NParr) - integer, intent(in) :: n !< Number of levels - integer, intent(in) :: ns !< Number of neutral surfaces - real, intent(in) :: Pint(n+1) !< Position of interface [Pa] + integer, intent(in) :: n !< Number of levels + integer, intent(in) :: ns !< Number of neutral surfaces + real, intent(in) :: Pint(n+1) !< Position of interface [R L2 T-2 ~> Pa] or other units integer, intent(in) :: Karr(ns) !< Indexes of interfaces about positions real, intent(in) :: NParr(ns) !< Non-dimensional positions within layers Karr(:) - real, dimension(ns) :: absolute_positions ! Absolute positions [Pa] + real, dimension(ns) :: absolute_positions !< Absolute positions [R L2 T-2 ~> Pa] + !! or other units following Pint ! Local variables integer :: k_surface, k @@ -1834,8 +1855,8 @@ subroutine neutral_surface_flux(nk, nsurf, deg, hl, hr, Tl, Tr, PiL, PiR, KoL, K integer, intent(in) :: nk !< Number of levels integer, intent(in) :: nsurf !< Number of neutral surfaces integer, intent(in) :: deg !< Degree of polynomial reconstructions - real, dimension(nk), intent(in) :: hl !< Left-column layer thickness [H or Pa] - real, dimension(nk), intent(in) :: hr !< Right-column layer thickness [H or Pa] + real, dimension(nk), intent(in) :: hl !< Left-column layer thickness [H ~> m or kg m-2] + real, dimension(nk), intent(in) :: hr !< Right-column layer thickness [H ~> m or kg m-2] real, dimension(nk), intent(in) :: Tl !< Left-column layer tracer (conc, e.g. degC) real, dimension(nk), intent(in) :: Tr !< Right-column layer tracer (conc, e.g. degC) real, dimension(nsurf), intent(in) :: PiL !< Fractional position of neutral surface @@ -1844,16 +1865,16 @@ subroutine neutral_surface_flux(nk, nsurf, deg, hl, hr, Tl, Tr, PiL, PiR, KoL, K !! within layer KoR of right column integer, dimension(nsurf), intent(in) :: KoL !< Index of first left interface above neutral surface integer, dimension(nsurf), intent(in) :: KoR !< Index of first right interface above neutral surface - real, dimension(nsurf-1), intent(in) :: hEff !< Effective thickness between two neutral surfaces [Pa] + real, dimension(nsurf-1), intent(in) :: hEff !< Effective thickness between two neutral + !! surfaces [H ~> m or kg m-2] real, dimension(nsurf-1), intent(inout) :: Flx !< Flux of tracer between pairs of neutral layers (conc H) logical, intent(in) :: continuous !< True if using continuous reconstruction real, intent(in) :: h_neglect !< A negligibly small width for the - !! purpose of cell reconstructions - !! in the same units as h0. + !! purpose of cell reconstructions [H ~> m or kg m-2] 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 used for - !! edge value calculations if continuous is false. + !! edge value calculations if continuous is false [H ~> m or kg m-2] ! Local variables integer :: k_sublayer, klb, klt, krb, krt, k real :: T_right_top, T_right_bottom, T_right_layer, T_right_sub, T_right_top_int, T_right_bot_int @@ -2313,18 +2334,23 @@ logical function ndiff_unit_tests_discontinuous(verbose) ! Local variables integer, parameter :: nk = 3 integer, parameter :: ns = nk*4 - real, dimension(nk) :: Sl, Sr, Tl, Tr, hl, hr - real, dimension(nk,2) :: TiL, SiL, TiR, SiR - real, dimension(nk,2) :: Pres_l, Pres_r + real, dimension(nk) :: Sl, Sr, Tl, Tr ! Salinities [ppt] and temperatures [degC] + real, dimension(nk) :: hl, hr ! Thicknesses in pressure units [R L2 T-2 ~> Pa] + real, dimension(nk,2) :: TiL, SiL, TiR, SiR ! Cell edge salinities [ppt] and temperatures [degC] + real, dimension(nk,2) :: Pres_l, Pres_r ! Interface pressures [R L2 T-2 ~> Pa] integer, dimension(ns) :: KoL, KoR real, dimension(ns) :: PoL, PoR real, dimension(ns-1) :: hEff, Flx type(neutral_diffusion_CS) :: CS !< Neutral diffusion control structure type(EOS_type), pointer :: EOS !< Structure for linear equation of state + type(unit_scale_type), pointer :: US !< A dimensional unit scaling type type(remapping_CS), pointer :: remap_CS !< Remapping control structure (PLM) real, dimension(nk,2) :: ppoly_T_l, ppoly_T_r ! Linear reconstruction for T real, dimension(nk,2) :: ppoly_S_l, ppoly_S_r ! Linear reconstruction for S - real, dimension(nk,2) :: dRdT, dRdS + real, dimension(nk,2) :: dRdT !< Partial derivative of density with temperature at + !! cell edges [R degC-1 ~> kg m-3 degC-1] + real, dimension(nk,2) :: dRdS !< Partial derivative of density with salinity at + !! cell edges [R ppt-1 ~> kg m-3 ppt-1] logical, dimension(nk) :: stable_l, stable_r integer :: iMethod integer :: ns_l, ns_r @@ -2338,7 +2364,8 @@ logical function ndiff_unit_tests_discontinuous(verbose) ! Unit tests for find_neutral_surface_positions_discontinuous ! Salinity is 0 for all these tests allocate(CS%EOS) - call EOS_manual_init(CS%EOS, form_of_EOS = EOS_LINEAR, dRho_dT = -1., dRho_dS = 0.) + call unit_scaling_init(US=US) + call EOS_manual_init(CS%EOS, form_of_EOS=EOS_LINEAR, dRho_dT=-1., dRho_dS=0.) Sl(:) = 0. ; Sr(:) = 0. ; ; SiL(:,:) = 0. ; SiR(:,:) = 0. ppoly_T_l(:,:) = 0.; ppoly_T_r(:,:) = 0. ppoly_S_l(:,:) = 0.; ppoly_S_r(:,:) = 0. @@ -2358,10 +2385,10 @@ logical function ndiff_unit_tests_discontinuous(verbose) TiL(1,:) = (/ 22.00, 18.00 /); TiL(2,:) = (/ 18.00, 14.00 /); TiL(3,:) = (/ 14.00, 10.00 /); TiR(1,:) = (/ 22.00, 18.00 /); TiR(2,:) = (/ 18.00, 14.00 /); TiR(3,:) = (/ 14.00, 10.00 /); - call mark_unstable_cells( CS, nk, Til, Sil, Pres_l, stable_l ) - call mark_unstable_cells( CS, nk, Tir, Sir, Pres_r, stable_r ) - call find_neutral_surface_positions_discontinuous(CS, nk, Pres_l, hL, TiL, SiL, ppoly_T_l, ppoly_S_l, stable_l, & - Pres_r, hR, TiR, SiR, ppoly_T_r, ppoly_S_r, stable_r, PoL, PoR, KoL, KoR, hEff) + call mark_unstable_cells( CS, nk, Til, Sil, Pres_l, US, stable_l ) + call mark_unstable_cells( CS, nk, Tir, Sir, Pres_r, US, stable_r ) + call find_neutral_surface_positions_discontinuous(CS, US, nk, Pres_l, hL, TiL, SiL, ppoly_T_l, ppoly_S_l, stable_l, & + Pres_r, hR, TiR, SiR, ppoly_T_r, ppoly_S_r, stable_r, PoL, PoR, KoL, KoR, hEff) ndiff_unit_tests_discontinuous = ndiff_unit_tests_discontinuous .or. test_nsp(v, 12, KoL, KoR, PoL, PoR, hEff, & (/ 1, 1, 1, 1, 2, 2, 2, 2, 3, 3, 3, 3 /), & ! KoL (/ 1, 1, 1, 2, 2, 2, 2, 3, 3, 3, 3, 3 /), & ! KoR @@ -2372,10 +2399,10 @@ logical function ndiff_unit_tests_discontinuous(verbose) TiL(1,:) = (/ 22.00, 18.00 /); TiL(2,:) = (/ 18.00, 14.00 /); TiL(3,:) = (/ 14.00, 10.00 /); TiR(1,:) = (/ 20.00, 16.00 /); TiR(2,:) = (/ 16.00, 12.00 /); TiR(3,:) = (/ 12.00, 8.00 /); - call mark_unstable_cells( CS, nk, Til, Sil, Pres_l, stable_l ) - call mark_unstable_cells( CS, nk, Tir, Sir, Pres_r, stable_r ) - call find_neutral_surface_positions_discontinuous(CS, nk, Pres_l, hL, TiL, SiL, ppoly_T_l, ppoly_S_l, stable_l, & - Pres_r, hR, TiR, SiR, ppoly_T_r, ppoly_S_r, stable_r, PoL, PoR, KoL, KoR, hEff) + call mark_unstable_cells( CS, nk, Til, Sil, Pres_l, US, stable_l ) + call mark_unstable_cells( CS, nk, Tir, Sir, Pres_r, US, stable_r ) + call find_neutral_surface_positions_discontinuous(CS, US, nk, Pres_l, hL, TiL, SiL, ppoly_T_l, ppoly_S_l, stable_l, & + Pres_r, hR, TiR, SiR, ppoly_T_r, ppoly_S_r, stable_r, PoL, PoR, KoL, KoR, hEff) ndiff_unit_tests_discontinuous = ndiff_unit_tests_discontinuous .or. test_nsp(v, 12, KoL, KoR, PoL, PoR, hEff, & (/ 1, 1, 1, 2, 2, 2, 2, 3, 3, 3, 3, 3 /), & ! KoL (/ 1, 1, 1, 1, 1, 2, 2, 2, 2, 3, 3, 3 /), & ! KoR @@ -2386,10 +2413,10 @@ logical function ndiff_unit_tests_discontinuous(verbose) TiL(1,:) = (/ 20.00, 16.00 /); TiL(2,:) = (/ 16.00, 12.00 /); TiL(3,:) = (/ 12.00, 8.00 /); TiR(1,:) = (/ 22.00, 18.00 /); TiR(2,:) = (/ 18.00, 14.00 /); TiR(3,:) = (/ 14.00, 10.00 /); - call mark_unstable_cells( CS, nk, Til, Sil, Pres_l, stable_l ) - call mark_unstable_cells( CS, nk, Tir, Sir, Pres_r, stable_r ) - call find_neutral_surface_positions_discontinuous(CS, nk, Pres_l, hL, TiL, SiL, ppoly_T_l, ppoly_S_l, stable_l, & - Pres_r, hR, TiR, SiR, ppoly_T_r, ppoly_S_r, stable_r, PoL, PoR, KoL, KoR, hEff) + call mark_unstable_cells( CS, nk, Til, Sil, Pres_l, US, stable_l ) + call mark_unstable_cells( CS, nk, Tir, Sir, Pres_r, US, stable_r ) + call find_neutral_surface_positions_discontinuous(CS, US, nk, Pres_l, hL, TiL, SiL, ppoly_T_l, ppoly_S_l, stable_l, & + Pres_r, hR, TiR, SiR, ppoly_T_r, ppoly_S_r, stable_r, PoL, PoR, KoL, KoR, hEff) ndiff_unit_tests_discontinuous = ndiff_unit_tests_discontinuous .or. test_nsp(v, 12, KoL, KoR, PoL, PoR, hEff, & (/ 1, 1, 1, 1, 1, 2, 2, 2, 2, 3, 3, 3 /), & ! KoL (/ 1, 1, 1, 2, 2, 2, 2, 3, 3, 3, 3, 3 /), & ! KoR @@ -2400,10 +2427,10 @@ logical function ndiff_unit_tests_discontinuous(verbose) TiL(1,:) = (/ 22.00, 20.00 /); TiL(2,:) = (/ 18.00, 16.00 /); TiL(3,:) = (/ 14.00, 12.00 /); TiR(1,:) = (/ 32.00, 24.00 /); TiR(2,:) = (/ 22.00, 14.00 /); TiR(3,:) = (/ 12.00, 4.00 /); - call mark_unstable_cells( CS, nk, Til, Sil, Pres_l, stable_l ) - call mark_unstable_cells( CS, nk, Tir, Sir, Pres_r, stable_r ) - call find_neutral_surface_positions_discontinuous(CS, nk, Pres_l, hL, TiL, SiL, ppoly_T_l, ppoly_S_l, stable_l, & - Pres_r, hR, TiR, SiR, ppoly_T_r, ppoly_S_r, stable_r, PoL, PoR, KoL, KoR, hEff) + call mark_unstable_cells( CS, nk, Til, Sil, Pres_l, US, stable_l ) + call mark_unstable_cells( CS, nk, Tir, Sir, Pres_r, US, stable_r ) + call find_neutral_surface_positions_discontinuous(CS, US, nk, Pres_l, hL, TiL, SiL, ppoly_T_l, ppoly_S_l, stable_l, & + Pres_r, hR, TiR, SiR, ppoly_T_r, ppoly_S_r, stable_r, PoL, PoR, KoL, KoR, hEff) ndiff_unit_tests_discontinuous = ndiff_unit_tests_discontinuous .or. test_nsp(v, 12, KoL, KoR, PoL, PoR, hEff, & (/ 1, 1, 1, 1, 1, 2, 2, 3, 3, 3, 3, 3 /), & ! KoL (/ 1, 1, 2, 2, 2, 2, 2, 2, 3, 3, 3, 3 /), & ! KoR @@ -2414,10 +2441,10 @@ logical function ndiff_unit_tests_discontinuous(verbose) TiL(1,:) = (/ 22.00, 18.00 /); TiL(2,:) = (/ 18.00, 14.00 /); TiL(3,:) = (/ 14.00, 10.00 /); TiR(1,:) = (/ 14.00, 14.00 /); TiR(2,:) = (/ 14.00, 14.00 /); TiR(3,:) = (/ 12.00, 8.00 /); - call mark_unstable_cells( CS, nk, Til, Sil, Pres_l, stable_l ) - call mark_unstable_cells( CS, nk, Tir, Sir, Pres_r, stable_r ) - call find_neutral_surface_positions_discontinuous(CS, nk, Pres_l, hL, TiL, SiL, ppoly_T_l, ppoly_S_l, stable_l, & - Pres_r, hR, TiR, SiR, ppoly_T_r, ppoly_S_r, stable_r, PoL, PoR, KoL, KoR, hEff) + call mark_unstable_cells( CS, nk, Til, Sil, Pres_l, US, stable_l ) + call mark_unstable_cells( CS, nk, Tir, Sir, Pres_r, US, stable_r ) + call find_neutral_surface_positions_discontinuous(CS, US, nk, Pres_l, hL, TiL, SiL, ppoly_T_l, ppoly_S_l, stable_l, & + Pres_r, hR, TiR, SiR, ppoly_T_r, ppoly_S_r, stable_r, PoL, PoR, KoL, KoR, hEff) ndiff_unit_tests_discontinuous = ndiff_unit_tests_discontinuous .or. test_nsp(v, 12, KoL, KoR, PoL, PoR, hEff, & (/ 1, 1, 1, 1, 1, 1, 2, 2, 3, 3, 3, 3 /), & ! KoL (/ 1, 1, 2, 2, 3, 3, 3, 3, 3, 3, 3, 3 /), & ! KoR @@ -2428,10 +2455,10 @@ logical function ndiff_unit_tests_discontinuous(verbose) TiL(1,:) = (/ 14.00, 14.00 /); TiL(2,:) = (/ 14.00, 12.00 /); TiL(3,:) = (/ 10.00, 8.00 /); TiR(1,:) = (/ 14.00, 14.00 /); TiR(2,:) = (/ 14.00, 14.00 /); TiR(3,:) = (/ 14.00, 14.00 /); - call mark_unstable_cells( CS, nk, Til, Sil, Pres_l, stable_l ) - call mark_unstable_cells( CS, nk, Tir, Sir, Pres_r, stable_r ) - call find_neutral_surface_positions_discontinuous(CS, nk, Pres_l, hL, TiL, SiL, ppoly_T_l, ppoly_S_l, stable_l, & - Pres_r, hR, TiR, SiR, ppoly_T_r, ppoly_S_r, stable_r, PoL, PoR, KoL, KoR, hEff) + call mark_unstable_cells( CS, nk, Til, Sil, Pres_l, US, stable_l ) + call mark_unstable_cells( CS, nk, Tir, Sir, Pres_r, US, stable_r ) + call find_neutral_surface_positions_discontinuous(CS, US, nk, Pres_l, hL, TiL, SiL, ppoly_T_l, ppoly_S_l, stable_l, & + Pres_r, hR, TiR, SiR, ppoly_T_r, ppoly_S_r, stable_r, PoL, PoR, KoL, KoR, hEff) ndiff_unit_tests_discontinuous = ndiff_unit_tests_discontinuous .or. test_nsp(v, 12, KoL, KoR, PoL, PoR, hEff, & (/ 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 3 /), & ! KoL (/ 1, 1, 1, 1, 2, 2, 3, 3, 3, 3, 3, 3 /), & ! KoR @@ -2442,10 +2469,10 @@ logical function ndiff_unit_tests_discontinuous(verbose) TiL(1,:) = (/ 14.00, 14.00 /); TiL(2,:) = (/ 14.00, 12.00 /); TiL(3,:) = (/ 10.00, 8.00 /); TiR(1,:) = (/ 14.00, 14.00 /); TiR(2,:) = (/ 14.00, 14.00 /); TiR(3,:) = (/ 12.00, 4.00 /); - call mark_unstable_cells( CS, nk, Til, Sil, Pres_l, stable_l ) - call mark_unstable_cells( CS, nk, Tir, Sir, Pres_r, stable_r ) - call find_neutral_surface_positions_discontinuous(CS, nk, Pres_l, hL, TiL, SiL, ppoly_T_l, ppoly_S_l, stable_l, & - Pres_r, hR, TiR, SiR, ppoly_T_r, ppoly_S_r, stable_r, PoL, PoR, KoL, KoR, hEff) + call mark_unstable_cells( CS, nk, Til, Sil, Pres_l, US, stable_l ) + call mark_unstable_cells( CS, nk, Tir, Sir, Pres_r, US, stable_r ) + call find_neutral_surface_positions_discontinuous(CS, US, nk, Pres_l, hL, TiL, SiL, ppoly_T_l, ppoly_S_l, stable_l, & + Pres_r, hR, TiR, SiR, ppoly_T_r, ppoly_S_r, stable_r, PoL, PoR, KoL, KoR, hEff) ndiff_unit_tests_discontinuous = ndiff_unit_tests_discontinuous .or. test_nsp(v, 12, KoL, KoR, PoL, PoR, hEff, & (/ 1, 1, 1, 1, 1, 1, 2, 2, 2, 3, 3, 3 /), & ! KoL (/ 1, 1, 1, 1, 2, 2, 3, 3, 3, 3, 3, 3 /), & ! KoR @@ -2456,10 +2483,10 @@ logical function ndiff_unit_tests_discontinuous(verbose) TiL(1,:) = (/ 14.00, 14.00 /); TiL(2,:) = (/ 14.00, 10.00 /); TiL(3,:) = (/ 10.00, 2.00 /); TiR(1,:) = (/ 14.00, 14.00 /); TiR(2,:) = (/ 14.00, 10.00 /); TiR(3,:) = (/ 10.00, 2.00 /); - call mark_unstable_cells( CS, nk, Til, Sil, Pres_l, stable_l ) - call mark_unstable_cells( CS, nk, Tir, Sir, Pres_r, stable_r ) - call find_neutral_surface_positions_discontinuous(CS, nk, Pres_l, hL, TiL, SiL, ppoly_T_l, ppoly_S_l, stable_l, & - Pres_r, hR, TiR, SiR, ppoly_T_r, ppoly_S_r, stable_r, PoL, PoR, KoL, KoR, hEff) + call mark_unstable_cells( CS, nk, Til, Sil, Pres_l, US, stable_l ) + call mark_unstable_cells( CS, nk, Tir, Sir, Pres_r, US, stable_r ) + call find_neutral_surface_positions_discontinuous(CS, US, nk, Pres_l, hL, TiL, SiL, ppoly_T_l, ppoly_S_l, stable_l, & + Pres_r, hR, TiR, SiR, ppoly_T_r, ppoly_S_r, stable_r, PoL, PoR, KoL, KoR, hEff) ndiff_unit_tests_discontinuous = ndiff_unit_tests_discontinuous .or. test_nsp(v, 12, KoL, KoR, PoL, PoR, hEff, & (/ 1, 1, 1, 1, 2, 2, 2, 2, 3, 3, 3, 3 /), & ! KoL (/ 1, 1, 1, 1, 2, 2, 2, 3, 3, 3, 3, 3 /), & ! KoR @@ -2470,10 +2497,10 @@ logical function ndiff_unit_tests_discontinuous(verbose) TiL(1,:) = (/ 14.00, 12.00 /); TiL(2,:) = (/ 10.00, 10.00 /); TiL(3,:) = (/ 8.00, 2.00 /); TiR(1,:) = (/ 14.00, 12.00 /); TiR(2,:) = (/ 12.00, 8.00 /); TiR(3,:) = (/ 8.00, 2.00 /); - call mark_unstable_cells( CS, nk, Til, Sil, Pres_l, stable_l ) - call mark_unstable_cells( CS, nk, Tir, Sir, Pres_r, stable_r ) - call find_neutral_surface_positions_discontinuous(CS, nk, Pres_l, hL, TiL, SiL, ppoly_T_l, ppoly_S_l, stable_l, & - Pres_r, hR, TiR, SiR, ppoly_T_r, ppoly_S_r, stable_r, PoL, PoR, KoL, KoR, hEff) + call mark_unstable_cells( CS, nk, Til, Sil, Pres_l, US, stable_l ) + call mark_unstable_cells( CS, nk, Tir, Sir, Pres_r, US, stable_r ) + call find_neutral_surface_positions_discontinuous(CS, US, nk, Pres_l, hL, TiL, SiL, ppoly_T_l, ppoly_S_l, stable_l, & + Pres_r, hR, TiR, SiR, ppoly_T_r, ppoly_S_r, stable_r, PoL, PoR, KoL, KoR, hEff) ndiff_unit_tests_discontinuous = ndiff_unit_tests_discontinuous .or. test_nsp(v, 12, KoL, KoR, PoL, PoR, hEff, & (/ 1, 1, 1, 1, 2, 2, 3, 3, 3, 3, 3, 3 /), & ! KoL (/ 1, 1, 1, 2, 2, 2, 2, 2, 2, 3, 3, 3 /), & ! KoR @@ -2484,10 +2511,10 @@ logical function ndiff_unit_tests_discontinuous(verbose) TiL(1,:) = (/ 12.00, 12.00 /); TiL(2,:) = (/ 12.00, 10.00 /); TiL(3,:) = (/ 10.00, 6.00 /); TiR(1,:) = (/ 12.00, 10.00 /); TiR(2,:) = (/ 10.00, 12.00 /); TiR(3,:) = (/ 8.00, 4.00 /); - call mark_unstable_cells( CS, nk, Til, Sil, Pres_l, stable_l ) - call mark_unstable_cells( CS, nk, Tir, Sir, Pres_r, stable_r ) - call find_neutral_surface_positions_discontinuous(CS, nk, Pres_l, hL, TiL, SiL, ppoly_T_l, ppoly_S_l, stable_l, & - Pres_r, hR, TiR, SiR, ppoly_T_r, ppoly_S_r, stable_r, PoL, PoR, KoL, KoR, hEff) + call mark_unstable_cells( CS, nk, Til, Sil, Pres_l, US, stable_l ) + call mark_unstable_cells( CS, nk, Tir, Sir, Pres_r, US, stable_r ) + call find_neutral_surface_positions_discontinuous(CS, US, nk, Pres_l, hL, TiL, SiL, ppoly_T_l, ppoly_S_l, stable_l, & + Pres_r, hR, TiR, SiR, ppoly_T_r, ppoly_S_r, stable_r, PoL, PoR, KoL, KoR, hEff) ndiff_unit_tests_discontinuous = ndiff_unit_tests_discontinuous .or. test_nsp(v, 12, KoL, KoR, PoL, PoR, hEff, & (/ 1, 1, 2, 2, 2, 3, 3, 3, 3, 3, 3, 3 /), & ! KoL (/ 1, 1, 1, 1, 1, 1, 2, 2, 3, 3, 3, 3 /), & ! KoR @@ -2498,10 +2525,10 @@ logical function ndiff_unit_tests_discontinuous(verbose) TiL(1,:) = (/ 14.00, 14.00 /); TiL(2,:) = (/ 10.00, 10.00 /); TiL(3,:) = (/ 8.00, 6.00 /); TiR(1,:) = (/ 10.00, 14.00 /); TiR(2,:) = (/ 16.00, 16.00 /); TiR(3,:) = (/ 12.00, 4.00 /); - call mark_unstable_cells( CS, nk, Til, Sil, Pres_l, stable_l ) - call mark_unstable_cells( CS, nk, Tir, Sir, Pres_r, stable_r ) - call find_neutral_surface_positions_discontinuous(CS, nk, Pres_l, hL, TiL, SiL, ppoly_T_l, ppoly_S_l, stable_l, & - Pres_r, hR, TiR, SiR, ppoly_T_r, ppoly_S_r, stable_r, PoL, PoR, KoL, KoR, hEff) + call mark_unstable_cells( CS, nk, Til, Sil, Pres_l, US, stable_l ) + call mark_unstable_cells( CS, nk, Tir, Sir, Pres_r, US, stable_r ) + call find_neutral_surface_positions_discontinuous(CS, US, nk, Pres_l, hL, TiL, SiL, ppoly_T_l, ppoly_S_l, stable_l, & + Pres_r, hR, TiR, SiR, ppoly_T_r, ppoly_S_r, stable_r, PoL, PoR, KoL, KoR, hEff) ndiff_unit_tests_discontinuous = ndiff_unit_tests_discontinuous .or. test_nsp(v, 12, KoL, KoR, PoL, PoR, hEff, & (/ 1, 1, 2, 2, 2, 2, 2, 2, 3, 3, 3, 3 /), & ! KoL (/ 1, 1, 1, 1, 1, 1, 2, 2, 3, 3, 3, 3 /), & ! KoR @@ -2512,10 +2539,10 @@ logical function ndiff_unit_tests_discontinuous(verbose) TiL(1,:) = (/ 8.00, 12.00 /); TiL(2,:) = (/ 12.00, 10.00 /); TiL(3,:) = (/ 8.00, 4.00 /); TiR(1,:) = (/ 10.00, 14.00 /); TiR(2,:) = (/ 14.00, 12.00 /); TiR(3,:) = (/ 10.00, 6.00 /); - call mark_unstable_cells( CS, nk, Til, Sil, Pres_l, stable_l ) - call mark_unstable_cells( CS, nk, Tir, Sir, Pres_r, stable_r ) - call find_neutral_surface_positions_discontinuous(CS, nk, Pres_l, hL, TiL, SiL, ppoly_T_l, ppoly_S_l, stable_l, & - Pres_r, hR, TiR, SiR, ppoly_T_r, ppoly_S_r, stable_r, PoL, PoR, KoL, KoR, hEff) + call mark_unstable_cells( CS, nk, Til, Sil, Pres_l, US, stable_l ) + call mark_unstable_cells( CS, nk, Tir, Sir, Pres_r, US, stable_r ) + call find_neutral_surface_positions_discontinuous(CS, US, nk, Pres_l, hL, TiL, SiL, ppoly_T_l, ppoly_S_l, stable_l, & + Pres_r, hR, TiR, SiR, ppoly_T_r, ppoly_S_r, stable_r, PoL, PoR, KoL, KoR, hEff) ndiff_unit_tests_discontinuous = ndiff_unit_tests_discontinuous .or. test_nsp(v, 12, KoL, KoR, PoL, PoR, hEff, & (/ 1, 1, 1, 1, 2, 2, 2, 2, 3, 3, 3, 3 /), & ! KoL (/ 1, 1, 1, 1, 2, 2, 2, 3, 3, 3, 3, 3 /), & ! KoR @@ -2531,29 +2558,29 @@ logical function ndiff_unit_tests_discontinuous(verbose) ! Unit tests require explicit initialization of tolerance CS%Drho_tol = 0. CS%x_tol = 0. - ndiff_unit_tests_discontinuous = ndiff_unit_tests_discontinuous .or. (test_rnp(0.5, & - find_neutral_pos_linear(CS, 0., 10., 35., 0., -0.2, 0., & - 0., -0.2, 0., 10., -0.2, 0., & + ndiff_unit_tests_discontinuous = ndiff_unit_tests_discontinuous .or. (test_rnp(0.5, & + find_neutral_pos_linear(CS, 0., 10., 35., -0.2, 0., & + -0.2, 0., -0.2, 0., & (/12.,-4./), (/34.,0./)), "Temp Uniform Linearized Alpha/Beta")) ! EOS linear in S, uniform beta ndiff_unit_tests_discontinuous = ndiff_unit_tests_discontinuous .or. (test_rnp(0.5, & - find_neutral_pos_linear(CS, 0., 10., 35., 0., 0., 0.8, & - 0., 0., 0.8, 10., 0., 0.8, & + find_neutral_pos_linear(CS, 0., 10., 35., 0., 0.8, & + 0., 0.8, 0., 0.8, & (/12.,0./), (/34.,2./)), "Salt Uniform Linearized Alpha/Beta")) ! EOS linear in T/S, uniform alpha/beta ndiff_unit_tests_discontinuous = ndiff_unit_tests_discontinuous .or. (test_rnp(0.5, & - find_neutral_pos_linear(CS, 0., 10., 35., 0., -0.5, 0.5, & - 0., -0.5, 0.5, 10., -0.5, 0.5, & + find_neutral_pos_linear(CS, 0., 10., 35., -0.5, 0.5, & + -0.5, 0.5, -0.5, 0.5, & (/12.,-4./), (/34.,2./)), "Temp/salt Uniform Linearized Alpha/Beta")) ! EOS linear in T, insensitive to So ndiff_unit_tests_discontinuous = ndiff_unit_tests_discontinuous .or. (test_rnp(0.5, & - find_neutral_pos_linear(CS, 0., 10., 35., 0., -0.2, 0., & - 0., -0.4, 0., 10., -0.6, 0., & + find_neutral_pos_linear(CS, 0., 10., 35., -0.2, 0., & + -0.4, 0., -0.6, 0., & (/12.,-4./), (/34.,0./)), "Temp stratified Linearized Alpha/Beta")) ! EOS linear in S, insensitive to T ndiff_unit_tests_discontinuous = ndiff_unit_tests_discontinuous .or. (test_rnp(0.5, & - find_neutral_pos_linear(CS, 0., 10., 35., 0., 0., 0.8, & - 0., 0., 1.0, 10., 0., 0.5, & + find_neutral_pos_linear(CS, 0., 10., 35., 0., 0.8, & + 0., 1.0, 0., 0.5, & (/12.,0./), (/34.,2./)), "Salt stratified Linearized Alpha/Beta")) if (.not. ndiff_unit_tests_discontinuous) write(*,*) 'Pass' @@ -2562,13 +2589,13 @@ end function ndiff_unit_tests_discontinuous !> Returns true if a test of fv_diff() fails, and conditionally writes results to stream logical function test_fv_diff(verbose, hkm1, hk, hkp1, Skm1, Sk, Skp1, Ptrue, title) logical, intent(in) :: verbose !< If true, write results to stdout - real, intent(in) :: hkm1 !< Left cell width - real, intent(in) :: hk !< Center cell width - real, intent(in) :: hkp1 !< Right cell width + real, intent(in) :: hkm1 !< Left cell width [nondim] + real, intent(in) :: hk !< Center cell width [nondim] + real, intent(in) :: hkp1 !< Right cell width [nondim] real, intent(in) :: Skm1 !< Left cell average value real, intent(in) :: Sk !< Center cell average value real, intent(in) :: Skp1 !< Right cell average value - real, intent(in) :: Ptrue !< True answer [Pa] + real, intent(in) :: Ptrue !< True answer [nondim] character(len=*), intent(in) :: title !< Title for messages ! Local variables @@ -2600,7 +2627,7 @@ logical function test_fvlsq_slope(verbose, hkm1, hk, hkp1, Skm1, Sk, Skp1, Ptrue real, intent(in) :: Skm1 !< Left cell average value real, intent(in) :: Sk !< Center cell average value real, intent(in) :: Skp1 !< Right cell average value - real, intent(in) :: Ptrue !< True answer [Pa] + real, intent(in) :: Ptrue !< True answer character(len=*), intent(in) :: title !< Title for messages ! Local variables @@ -2626,11 +2653,11 @@ end function test_fvlsq_slope !> Returns true if a test of interpolate_for_nondim_position() fails, and conditionally writes results to stream logical function test_ifndp(verbose, rhoNeg, Pneg, rhoPos, Ppos, Ptrue, title) logical, intent(in) :: verbose !< If true, write results to stdout - real, intent(in) :: rhoNeg !< Lighter density [kg m-3] - real, intent(in) :: Pneg !< Interface position of lighter density [Pa] - real, intent(in) :: rhoPos !< Heavier density [kg m-3] - real, intent(in) :: Ppos !< Interface position of heavier density [Pa] - real, intent(in) :: Ptrue !< True answer [Pa] + real, intent(in) :: rhoNeg !< Lighter density [R ~> kg m-3] + real, intent(in) :: Pneg !< Interface position of lighter density [nondim] + real, intent(in) :: rhoPos !< Heavier density [R ~> kg m-3] + real, intent(in) :: Ppos !< Interface position of heavier density [nondim] + real, intent(in) :: Ptrue !< True answer [nondim] character(len=*), intent(in) :: title !< Title for messages ! Local variables @@ -2726,19 +2753,19 @@ end function test_data1di !> 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 + logical, intent(in) :: verbose !< If true, write results to stdout + integer, intent(in) :: ns !< Number of surfaces integer, dimension(ns), intent(in) :: KoL !< Index of first left interface above neutral surface integer, dimension(ns), intent(in) :: KoR !< Index of first right interface above neutral surface real, dimension(ns), intent(in) :: pL !< Fractional position of neutral surface within layer KoL of left column real, dimension(ns), intent(in) :: pR !< Fractional position of neutral surface within layer KoR of right column - real, dimension(ns-1), intent(in) :: hEff !< Effective thickness between two neutral surfaces [Pa] + real, dimension(ns-1), intent(in) :: hEff !< Effective thickness between two neutral surfaces [R L2 T-2 ~> Pa] integer, dimension(ns), intent(in) :: KoL0 !< Correct value for KoL integer, dimension(ns), intent(in) :: KoR0 !< Correct value for KoR real, dimension(ns), intent(in) :: pL0 !< Correct value for pL real, dimension(ns), intent(in) :: pR0 !< Correct value for pR - real, dimension(ns-1), intent(in) :: hEff0 !< Correct value for hEff - character(len=*), intent(in) :: title !< Title for messages + real, dimension(ns-1), intent(in) :: hEff0 !< Correct value for hEff + character(len=*), intent(in) :: title !< Title for messages ! Local variables integer :: k, stdunit diff --git a/src/tracer/MOM_tracer_hor_diff.F90 b/src/tracer/MOM_tracer_hor_diff.F90 index 93ca34257c..6aa70fa605 100644 --- a/src/tracer/MOM_tracer_hor_diff.F90 +++ b/src/tracer/MOM_tracer_hor_diff.F90 @@ -1424,7 +1424,7 @@ subroutine tracer_hor_diff_init(Time, G, US, param_file, diag, EOS, diabatic_CSp type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(diag_ctrl), target, intent(inout) :: diag !< diagnostic control type(EOS_type), target, intent(in) :: EOS !< Equation of state CS - type(diabatic_CS), pointer, intent(in) :: diabatic_CSp !< Equation of state CS + type(diabatic_CS), pointer, intent(in) :: diabatic_CSp !< Equation of state CS type(param_file_type), intent(in) :: param_file !< parameter file type(tracer_hor_diff_CS), pointer :: CS !< horz diffusion control structure @@ -1495,8 +1495,8 @@ subroutine tracer_hor_diff_init(Time, G, US, param_file, diag, EOS, diabatic_CSp units="nondim", default=1.0) endif - CS%use_neutral_diffusion = neutral_diffusion_init(Time, G, param_file, diag, EOS, diabatic_CSp, & - CS%neutral_diffusion_CSp ) + CS%use_neutral_diffusion = neutral_diffusion_init(Time, G, US, param_file, diag, EOS, & + diabatic_CSp, CS%neutral_diffusion_CSp ) if (CS%use_neutral_diffusion .and. CS%Diffuse_ML_interior) call MOM_error(FATAL, "MOM_tracer_hor_diff: "// & "USE_NEUTRAL_DIFFUSION and DIFFUSE_ML_TO_INTERIOR are mutually exclusive!") CS%use_lateral_boundary_diffusion = lateral_boundary_diffusion_init(Time, G, param_file, diag, diabatic_CSp, & From 7643bce4e48b4c108a79a756d6ae418b9e19d547 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Tue, 14 Apr 2020 16:45:57 -0400 Subject: [PATCH 180/316] Simpler calculate_density in ISOMIP_initialization Use the US form of calculate_density calls in ISOMIP_initialization. All answers are bitwise identical. --- src/user/ISOMIP_initialization.F90 | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/src/user/ISOMIP_initialization.F90 b/src/user/ISOMIP_initialization.F90 index ba8dc1162f..c189cf0490 100644 --- a/src/user/ISOMIP_initialization.F90 +++ b/src/user/ISOMIP_initialization.F90 @@ -281,7 +281,7 @@ subroutine ISOMIP_initialize_temperature_salinity ( T, S, h, G, GV, US, param_fi real :: drho_dT(SZK_(G)) ! Derivative of density with temperature [R degC-1 ~> kg m-3 degC-1]. real :: drho_dS(SZK_(G)) ! Derivative of density with salinity [R ppt-1 ~> kg m-3 ppt-1]. real :: rho_guess(SZK_(G)) ! Potential density at T0 & S0 [R ~> kg m-3]. - real :: pres(SZK_(G)) ! An array of the reference pressure [Pa]. (zero here) + real :: pres(SZK_(G)) ! An array of the reference pressure [R L2 T-2 ~> Pa]. (zero here) real :: drho_dT1 ! A prescribed derivative of density with temperature [R degC-1 ~> kg m-3 degC-1] real :: drho_dS1 ! A prescribed derivative of density with salinity [R ppt-1 ~> kg m-3 ppt-1]. real :: T_Ref, S_Ref @@ -362,10 +362,10 @@ subroutine ISOMIP_initialize_temperature_salinity ( T, S, h, G, GV, US, param_fi ! call MOM_mesg(mesg,5) enddo - call calculate_density_derivs(T0,S0,pres,drho_dT,drho_dS,1,1,eqn_of_state, scale=US%kg_m3_to_R) + call calculate_density_derivs(T0, S0, pres, drho_dT, drho_dS, 1, 1, eqn_of_state, US) ! write(mesg,*) 'computed drho_dS, drho_dT', drho_dS(1), drho_dT(1) ! call MOM_mesg(mesg,5) - call calculate_density(T0(1),S0(1),0.,rho_guess(1),eqn_of_state, scale=US%kg_m3_to_R) + call calculate_density(T0(1), S0(1), pres(1), rho_guess(1), eqn_of_state, US=US) if (fit_salin) then ! A first guess of the layers' salinity. @@ -374,8 +374,8 @@ subroutine ISOMIP_initialize_temperature_salinity ( T, S, h, G, GV, US, param_fi enddo ! Refine the guesses for each layer. do itt=1,6 - call calculate_density(T0,S0,pres,rho_guess,1,nz,eqn_of_state, scale=US%kg_m3_to_R) - call calculate_density_derivs(T0,S0,pres,drho_dT,drho_dS,1,nz,eqn_of_state, scale=US%kg_m3_to_R) + call calculate_density(T0, S0, pres, rho_guess, 1, nz, eqn_of_state, US=US) + call calculate_density_derivs(T0, S0, pres, drho_dT, drho_dS, 1, nz, eqn_of_state, US) do k=1,nz S0(k) = max(0.0, S0(k) + (GV%Rlay(k) - rho_guess(k)) / drho_dS1) enddo @@ -388,8 +388,8 @@ subroutine ISOMIP_initialize_temperature_salinity ( T, S, h, G, GV, US, param_fi enddo do itt=1,6 - call calculate_density(T0,S0,pres,rho_guess,1,nz,eqn_of_state, scale=US%kg_m3_to_R) - call calculate_density_derivs(T0,S0,pres,drho_dT,drho_dS,1,nz,eqn_of_state, scale=US%kg_m3_to_R) + call calculate_density(T0, S0, pres, rho_guess, 1, nz, eqn_of_state, US=US) + call calculate_density_derivs(T0, S0, pres, drho_dT, drho_dS, 1, nz, eqn_of_state, US) do k=1,nz T0(k) = T0(k) + (GV%Rlay(k) - rho_guess(k)) / drho_dT(k) enddo From 030a6368124e662bb6f35540947fcb440ffdc79d Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Tue, 14 Apr 2020 21:55:15 -0400 Subject: [PATCH 181/316] Nullify a pointer in neutral diffusion unit tests Nullified a pointer used in neutral diffusion unit tests. Without this correction of a problem introduced two commits ago, these unit tests would sometimes fail, but all solutions are bitwise identical. --- src/tracer/MOM_neutral_diffusion.F90 | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/src/tracer/MOM_neutral_diffusion.F90 b/src/tracer/MOM_neutral_diffusion.F90 index 0f025c3d39..64d5e134d7 100644 --- a/src/tracer/MOM_neutral_diffusion.F90 +++ b/src/tracer/MOM_neutral_diffusion.F90 @@ -2343,7 +2343,7 @@ logical function ndiff_unit_tests_discontinuous(verbose) real, dimension(ns-1) :: hEff, Flx type(neutral_diffusion_CS) :: CS !< Neutral diffusion control structure type(EOS_type), pointer :: EOS !< Structure for linear equation of state - type(unit_scale_type), pointer :: US !< A dimensional unit scaling type + type(unit_scale_type), pointer :: US => NULL() !< A dimensional unit scaling type type(remapping_CS), pointer :: remap_CS !< Remapping control structure (PLM) real, dimension(nk,2) :: ppoly_T_l, ppoly_T_r ! Linear reconstruction for T real, dimension(nk,2) :: ppoly_S_l, ppoly_S_r ! Linear reconstruction for S @@ -2584,6 +2584,8 @@ logical function ndiff_unit_tests_discontinuous(verbose) (/12.,0./), (/34.,2./)), "Salt stratified Linearized Alpha/Beta")) if (.not. ndiff_unit_tests_discontinuous) write(*,*) 'Pass' + deallocate(US) + end function ndiff_unit_tests_discontinuous !> Returns true if a test of fv_diff() fails, and conditionally writes results to stream From ad0c70e2a9ce3e909cd6541bdf9b5f9fe5db9f2a Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Tue, 14 Apr 2020 21:55:47 -0400 Subject: [PATCH 182/316] Rescaled three diagnosed densities Rescaled 3 diagnosed densities and the pressures used to calculate them. All answers are bitwise identical. --- src/diagnostics/MOM_diagnostics.F90 | 35 +++++++++++++---------------- 1 file changed, 16 insertions(+), 19 deletions(-) diff --git a/src/diagnostics/MOM_diagnostics.F90 b/src/diagnostics/MOM_diagnostics.F90 index 2aa0dee688..94f6acc9c3 100644 --- a/src/diagnostics/MOM_diagnostics.F90 +++ b/src/diagnostics/MOM_diagnostics.F90 @@ -232,12 +232,12 @@ subroutine calculate_diagnostic_fields(u, v, h, uh, vh, tv, ADp, CDp, p_surf, & ! tmp array for surface properties real :: surface_field(SZI_(G),SZJ_(G)) - real :: pressure_1d(SZI_(G)) ! Temporary array for pressure when calling EOS [R L2 T-2 ~> Pa] or [Pa] + real :: pressure_1d(SZI_(G)) ! Temporary array for pressure when calling EOS [R L2 T-2 ~> Pa] real :: wt, wt_p real :: f2_h ! Squared Coriolis parameter at to h-points [T-2 ~> s-2] real :: mag_beta ! Magnitude of the gradient of f [T-1 L-1 ~> s-1 m-1] - real :: absurdly_small_freq2 ! Srequency squared used to avoid division by 0 [T-2 ~> s-2] + real :: absurdly_small_freq2 ! Frequency squared used to avoid division by 0 [T-2 ~> s-2] integer :: k_list @@ -355,7 +355,7 @@ subroutine calculate_diagnostic_fields(u, v, h, uh, vh, tv, ADp, CDp, p_surf, & enddo endif do k=1,nz ! Integrate vertically downward for pressure - do i=is,ie ! Pressure for EOS at the layer center [Pa] + do i=is,ie ! Pressure for EOS at the layer center [R L2 T-2 ~> Pa] pressure_1d(i) = pressure_1d(i) + 0.5*(GV%H_to_RZ*GV%g_Earth)*h(i,j,k) enddo ! Store in-situ density [R ~> kg m-3] in work_3d @@ -364,7 +364,7 @@ subroutine calculate_diagnostic_fields(u, v, h, uh, vh, tv, ADp, CDp, p_surf, & do i=is,ie ! Cell thickness = dz = dp/(g*rho) (meter); store in work_3d work_3d(i,j,k) = (GV%H_to_RZ*h(i,j,k)) / rho_in_situ(i) enddo - do i=is,ie ! Pressure for EOS at the bottom interface [Pa] + do i=is,ie ! Pressure for EOS at the bottom interface [R L2 T-2 ~> Pa] pressure_1d(i) = pressure_1d(i) + 0.5*(GV%H_to_RZ*GV%g_Earth)*h(i,j,k) enddo enddo ! k @@ -586,31 +586,28 @@ subroutine calculate_diagnostic_fields(u, v, h, uh, vh, tv, ADp, CDp, p_surf, & if (associated(tv%eqn_of_state)) then if (CS%id_rhopot0 > 0) then pressure_1d(:) = 0. -!$OMP parallel do default(none) shared(tv,Rcv,is,ie,js,je,nz,pressure_1d) + !$OMP parallel do default(shared) do k=1,nz ; do j=js,je - call calculate_density(tv%T(:,j,k),tv%S(:,j,k),pressure_1d, & - Rcv(:,j,k),is,ie-is+1, tv%eqn_of_state) + call calculate_density(tv%T(:,j,k), tv%S(:,j,k), pressure_1d, Rcv(:,j,k), G%HI, tv%eqn_of_state, US) enddo ; enddo if (CS%id_rhopot0 > 0) call post_data(CS%id_rhopot0, Rcv, CS%diag) endif if (CS%id_rhopot2 > 0) then - pressure_1d(:) = 2.E7 ! 2000 dbars -!$OMP parallel do default(none) shared(tv,Rcv,is,ie,js,je,nz,pressure_1d) + pressure_1d(:) = 2.0e7*US%kg_m3_to_R*US%m_s_to_L_T**2 ! 2000 dbars + !$OMP parallel do default(shared) do k=1,nz ; do j=js,je - call calculate_density(tv%T(:,j,k),tv%S(:,j,k),pressure_1d, & - Rcv(:,j,k),is,ie-is+1, tv%eqn_of_state) + call calculate_density(tv%T(:,j,k), tv%S(:,j,k), pressure_1d, Rcv(:,j,k), G%HI, tv%eqn_of_state, US) enddo ; enddo if (CS%id_rhopot2 > 0) call post_data(CS%id_rhopot2, Rcv, CS%diag) endif if (CS%id_rhoinsitu > 0) then -!$OMP parallel do default(none) shared(tv,Rcv,is,ie,js,je,nz,h,GV) private(pressure_1d) + !$OMP parallel do default(shared) private(pressure_1d) do j=js,je pressure_1d(:) = 0. ! Start at p=0 Pa at surface do k=1,nz - pressure_1d(:) = pressure_1d(:) + 0.5 * h(:,j,k) * GV%H_to_Pa ! Pressure in middle of layer k - call calculate_density(tv%T(:,j,k),tv%S(:,j,k),pressure_1d, & - Rcv(:,j,k),is,ie-is+1, tv%eqn_of_state) - pressure_1d(:) = pressure_1d(:) + 0.5 * h(:,j,k) * GV%H_to_Pa ! Pressure at bottom of layer k + pressure_1d(:) = pressure_1d(:) + 0.5 * h(:,j,k) * (GV%H_to_RZ*GV%g_Earth) ! Pressure in middle of layer k + call calculate_density(tv%T(:,j,k), tv%S(:,j,k), pressure_1d, Rcv(:,j,k), G%HI, tv%eqn_of_state, US) + pressure_1d(:) = pressure_1d(:) + 0.5 * h(:,j,k) * (GV%H_to_RZ*GV%g_Earth) ! Pressure at bottom of layer k enddo enddo if (CS%id_rhoinsitu > 0) call post_data(CS%id_rhoinsitu, Rcv, CS%diag) @@ -1577,11 +1574,11 @@ subroutine MOM_diagnostics_init(MIS, ADp, CDp, Time, G, GV, US, param_file, diag 'Coordinate Potential Density', 'kg m-3', conversion=US%R_to_kg_m3) CS%id_rhopot0 = register_diag_field('ocean_model', 'rhopot0', diag%axesTL, Time, & - 'Potential density referenced to surface', 'kg m-3') + 'Potential density referenced to surface', 'kg m-3', conversion=US%R_to_kg_m3) CS%id_rhopot2 = register_diag_field('ocean_model', 'rhopot2', diag%axesTL, Time, & - 'Potential density referenced to 2000 dbar', 'kg m-3') + 'Potential density referenced to 2000 dbar', 'kg m-3', conversion=US%R_to_kg_m3) CS%id_rhoinsitu = register_diag_field('ocean_model', 'rhoinsitu', diag%axesTL, Time, & - 'In situ density', 'kg m-3') + 'In situ density', 'kg m-3', conversion=US%R_to_kg_m3) CS%id_du_dt = register_diag_field('ocean_model', 'dudt', diag%axesCuL, Time, & 'Zonal Acceleration', 'm s-2', conversion=US%L_T2_to_m_s2) From 608d210a6d2d5d05d00329566a4ed92d94da8120 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Tue, 14 Apr 2020 21:57:56 -0400 Subject: [PATCH 183/316] Rescaled pressures in wave speed calculations Rescaled pressures used in wave speed and structure calculations for expanded dimensional consistency testing and some code simplification. Some internal variables were renamed for greater clarity. All answers are bitwise identical. --- src/diagnostics/MOM_wave_speed.F90 | 36 ++++++++++++++------------ src/diagnostics/MOM_wave_structure.F90 | 11 ++++---- 2 files changed, 25 insertions(+), 22 deletions(-) diff --git a/src/diagnostics/MOM_wave_speed.F90 b/src/diagnostics/MOM_wave_speed.F90 index 56545dc50d..85dbcdc13b 100644 --- a/src/diagnostics/MOM_wave_speed.F90 +++ b/src/diagnostics/MOM_wave_speed.F90 @@ -76,7 +76,7 @@ subroutine wave_speed(h, tv, G, GV, US, cg1, CS, full_halos, use_ebt_mode, & real, dimension(SZK_(G)+1) :: & dRho_dT, & ! Partial derivative of density with temperature [R degC-1 ~> kg m-3 degC-1] dRho_dS, & ! Partial derivative of density with salinity [R ppt-1 ~> kg m-3 ppt-1] - pres, & ! Interface pressure [Pa] + pres, & ! Interface pressure [R L2 T-2 ~> Pa] T_int, & ! Temperature interpolated to interfaces [degC] S_int, & ! Salinity interpolated to interfaces [ppt] gprime ! The reduced gravity across each interface [L2 Z-1 T-2 ~> m s-2]. @@ -100,7 +100,7 @@ subroutine wave_speed(h, tv, G, GV, US, cg1, CS, full_halos, use_ebt_mode, & real :: dlam ! The change in estimates of the eigenvalue [T2 L-2 ~> s m-1] real :: lam0 ! The first guess of the eigenvalue [T2 L-2 ~> s m-1] real :: min_h_frac ! [nondim] - real :: Z_to_Pa ! A conversion factor from thicknesses (in Z) to pressure (in Pa) + real :: Z_to_pres ! A conversion factor from thicknesses to pressure [R L2 T-2 Z-1 ~> Pa m-1] real, dimension(SZI_(G)) :: & htot, hmin, & ! Thicknesses [Z ~> m] H_here, & ! A thickness [Z ~> m] @@ -158,7 +158,8 @@ subroutine wave_speed(h, tv, G, GV, US, cg1, CS, full_halos, use_ebt_mode, & S => tv%S ; T => tv%T g_Rho0 = GV%g_Earth / GV%Rho0 - Z_to_Pa = GV%Z_to_H * GV%H_to_Pa + ! Simplifying the following could change answers at roundoff. + Z_to_pres = GV%Z_to_H * (GV%H_to_RZ * GV%g_Earth) use_EOS = associated(tv%eqn_of_state) rescale = 1024.0**4 ; I_rescale = 1.0/rescale @@ -170,7 +171,7 @@ subroutine wave_speed(h, tv, G, GV, US, cg1, CS, full_halos, use_ebt_mode, & !$OMP parallel do default(none) shared(is,ie,js,je,nz,h,G,GV,US,min_h_frac,use_EOS,T,S,tv,& !$OMP calc_modal_structure,l_use_ebt_mode,modal_structure, & !$OMP l_mono_N2_column_fraction,l_mono_N2_depth,CS, & -!$OMP Z_to_Pa,cg1,g_Rho0,rescale,I_rescale,L2_to_Z2,c2_scale) & +!$OMP Z_to_pres,cg1,g_Rho0,rescale,I_rescale,L2_to_Z2,c2_scale) & !$OMP private(htot,hmin,kf,H_here,HxT_here,HxS_here,HxR_here, & !$OMP Hf,Tf,Sf,Rf,pres,T_int,S_int,drho_dT, & !$OMP drho_dS,drxh_sum,kc,Hc,Hc_H,Tc,Sc,I_Hnew,gprime,& @@ -237,12 +238,12 @@ subroutine wave_speed(h, tv, G, GV, US, cg1, CS, full_halos, use_ebt_mode, & if (use_EOS) then pres(1) = 0.0 do k=2,kf(i) - pres(k) = pres(k-1) + Z_to_Pa*Hf(k-1,i) + pres(k) = pres(k-1) + Z_to_pres*Hf(k-1,i) T_int(k) = 0.5*(Tf(k,i)+Tf(k-1,i)) S_int(k) = 0.5*(Sf(k,i)+Sf(k-1,i)) enddo call calculate_density_derivs(T_int, S_int, pres, drho_dT, drho_dS, 2, & - kf(i)-1, tv%eqn_of_state, scale=US%kg_m3_to_R) + kf(i)-1, tv%eqn_of_state, US) ! Sum the reduced gravities to find out how small a density difference ! is negligibly small. @@ -567,10 +568,10 @@ end subroutine tdma6 !> Calculates the wave speeds for the first few barolinic modes. subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, full_halos) - type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer thickness [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer thickness [H ~> m or kg m-2] type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamic variables integer, intent(in) :: nmodes !< Number of modes real, dimension(G%isd:G%ied,G%jsd:G%jed,nmodes), intent(out) :: cn !< Waves speeds [L T-1 ~> m s-1] @@ -581,7 +582,7 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, full_halos) real, dimension(SZK_(G)+1) :: & dRho_dT, & ! Partial derivative of density with temperature [R degC-1 ~> kg m-3 degC-1] dRho_dS, & ! Partial derivative of density with salinity [R ppt-1 ~> kg m-3 ppt-1] - pres, & ! Interface pressure [Pa] + pres, & ! Interface pressure [R L2 T-2 ~> Pa] T_int, & ! Temperature interpolated to interfaces [degC] S_int, & ! Salinity interpolated to interfaces [ppt] gprime ! The reduced gravity across each interface [L2 Z-1 T-2 ~> m s-2]. @@ -621,7 +622,7 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, full_halos) integer :: numint ! number of widows (intervals) in root searching range integer :: nrootsfound ! number of extra roots found (not including 1st root) real :: min_h_frac - real :: Z_to_Pa ! A conversion factor from thicknesses (in Z) to pressure (in Pa) + real :: Z_to_pres ! A conversion factor from thicknesses to pressure [R L2 T-2 Z-1 ~> Pa m-1] real, dimension(SZI_(G)) :: & htot, hmin, & ! Thicknesses [Z ~> m] H_here, & ! A thickness [Z ~> m] @@ -665,12 +666,13 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, full_halos) S => tv%S ; T => tv%T g_Rho0 = GV%g_Earth / GV%Rho0 use_EOS = associated(tv%eqn_of_state) - Z_to_Pa = GV%Z_to_H * GV%H_to_Pa + ! Simplifying the following could change answers at roundoff. + Z_to_pres = GV%Z_to_H * (GV%H_to_RZ * GV%g_Earth) c1_thresh = 0.01*US%m_s_to_L_T min_h_frac = tol1 / real(nz) !$OMP parallel do default(private) shared(is,ie,js,je,nz,h,G,GV,US,min_h_frac,use_EOS,T,S, & - !$OMP Z_to_Pa,tv,cn,g_Rho0,nmodes) + !$OMP Z_to_pres,tv,cn,g_Rho0,nmodes) do j=js,je ! First merge very thin layers with the one above (or below if they are ! at the top). This also transposes the row order so that columns can @@ -731,12 +733,12 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, full_halos) if (use_EOS) then pres(1) = 0.0 do k=2,kf(i) - pres(k) = pres(k-1) + Z_to_Pa*Hf(k-1,i) + pres(k) = pres(k-1) + Z_to_pres*Hf(k-1,i) T_int(k) = 0.5*(Tf(k,i)+Tf(k-1,i)) S_int(k) = 0.5*(Sf(k,i)+Sf(k-1,i)) enddo call calculate_density_derivs(T_int, S_int, pres, drho_dT, drho_dS, 2, & - kf(i)-1, tv%eqn_of_state, scale=US%kg_m3_to_R) + kf(i)-1, tv%eqn_of_state, US) ! Sum the reduced gravities to find out how small a density difference ! is negligibly small. @@ -879,7 +881,7 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, full_halos) ! Under estimate the first eigenvalue to start with. lam_1 = 1.0 / speed2_tot - ! Find the first eigen value + ! Find the first eigenvalue do itt=1,max_itt ! calculate the determinant of (A-lam_1*I) call tridiag_det(a_diag(1:nrows),b_diag(1:nrows),c_diag(1:nrows), & @@ -902,10 +904,10 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, full_halos) endif enddo - ! Find other eigen values if c1 is of significant magnitude, > cn_thresh + ! Find other eigenvalues if c1 is of significant magnitude, > cn_thresh nrootsfound = 0 ! number of extra roots found (not including 1st root) if (nmodes>1 .and. kc>=nmodes+1 .and. cn(i,j,1)>c1_thresh) then - ! Set the the range to look for the other desired eigen values + ! Set the the range to look for the other desired eigenvalues ! set min value just greater than the 1st root (found above) lamMin = lam_1*(1.0 + tol2) ! set max value based on a low guess at wavespeed for highest mode diff --git a/src/diagnostics/MOM_wave_structure.F90 b/src/diagnostics/MOM_wave_structure.F90 index 68667df71b..ceb6fd6c4f 100644 --- a/src/diagnostics/MOM_wave_structure.F90 +++ b/src/diagnostics/MOM_wave_structure.F90 @@ -109,7 +109,7 @@ subroutine wave_structure(h, tv, G, GV, US, cn, ModeNum, freq, CS, En, full_halo real, dimension(SZK_(G)+1) :: & dRho_dT, & ! Partial derivative of density with temperature [R degC-1 ~> kg m-3 degC-1] dRho_dS, & ! Partial derivative of density with salinity [R ppt-1 ~> kg m-3 ppt-1] - pres, & ! Interface pressure [Pa] + pres, & ! Interface pressure [R L2 T-2 ~> Pa] T_int, & ! Temperature interpolated to interfaces [degC] S_int, & ! Salinity interpolated to interfaces [ppt] gprime ! The reduced gravity across each interface [m2 Z-1 s-2 ~> m s-2]. @@ -131,7 +131,7 @@ subroutine wave_structure(h, tv, G, GV, US, cn, ModeNum, freq, CS, En, full_halo htot ! The vertical sum of the thicknesses [Z ~> m] real :: lam real :: min_h_frac - real :: H_to_pres + real :: Z_to_pres ! A conversion factor from thicknesses to pressure [R L2 T-2 Z-1 ~> Pa m-1] real, dimension(SZI_(G)) :: & hmin, & ! Thicknesses [Z ~> m] H_here, & ! A thickness [Z ~> m] @@ -199,7 +199,8 @@ subroutine wave_structure(h, tv, G, GV, US, cn, ModeNum, freq, CS, En, full_halo cg_subRO = 1e-100*US%m_s_to_L_T ! The hard-coded value here might need to increase. use_EOS = associated(tv%eqn_of_state) - H_to_pres = GV%Z_to_H*GV%H_to_Pa + ! Simplifying the following could change answers at roundoff. + Z_to_pres = GV%Z_to_H * (GV%H_to_RZ * GV%g_Earth) ! rescale = 1024.0**4 ; I_rescale = 1.0/rescale min_h_frac = tol1 / real(nz) @@ -272,12 +273,12 @@ subroutine wave_structure(h, tv, G, GV, US, cn, ModeNum, freq, CS, En, full_halo if (use_EOS) then pres(1) = 0.0 do k=2,kf(i) - pres(k) = pres(k-1) + H_to_pres*Hf(k-1,i) + pres(k) = pres(k-1) + Z_to_pres*Hf(k-1,i) T_int(k) = 0.5*(Tf(k,i)+Tf(k-1,i)) S_int(k) = 0.5*(Sf(k,i)+Sf(k-1,i)) enddo call calculate_density_derivs(T_int, S_int, pres, drho_dT, drho_dS, 2, & - kf(i)-1, tv%eqn_of_state, scale=US%kg_m3_to_R) + kf(i)-1, tv%eqn_of_state, US) ! Sum the reduced gravities to find out how small a density difference ! is negligibly small. From a01dae523f86a856fcea5b08abc0113250c0fd76 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Tue, 14 Apr 2020 21:58:37 -0400 Subject: [PATCH 184/316] Corrected 3 openMP declarations Corrected 3 openMP declarations. All answers are bitwise identical. --- src/core/MOM_PressureForce_blocked_AFV.F90 | 6 +++--- src/parameterizations/vertical/MOM_diabatic_aux.F90 | 5 ++--- 2 files changed, 5 insertions(+), 6 deletions(-) diff --git a/src/core/MOM_PressureForce_blocked_AFV.F90 b/src/core/MOM_PressureForce_blocked_AFV.F90 index d618060951..e949f6d69c 100644 --- a/src/core/MOM_PressureForce_blocked_AFV.F90 +++ b/src/core/MOM_PressureForce_blocked_AFV.F90 @@ -323,8 +323,8 @@ subroutine PressureForce_blk_AFV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, ! 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,US) & +!$OMP parallel do default(none) shared(nz,za,G,GV,dza,intx_dza,h,PFu,PFv,CS,dM,US, & +!$OMP intp_dza,p,dp_neglect,inty_dza,H_to_RL2_T2) & !$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) @@ -617,7 +617,7 @@ subroutine PressureForce_blk_AFV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, endif endif -!$OMP parallel do default(none) shared(use_p_atm,rho_ref,G,GV,e,p_atm,nz,use_EOS,& +!$OMP parallel do default(none) shared(use_p_atm,rho_ref,G,GV,US,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, & diff --git a/src/parameterizations/vertical/MOM_diabatic_aux.F90 b/src/parameterizations/vertical/MOM_diabatic_aux.F90 index dc8bbc2409..3cde9ce91e 100644 --- a/src/parameterizations/vertical/MOM_diabatic_aux.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_aux.F90 @@ -139,9 +139,8 @@ subroutine make_frazil(h, tv, G, GV, US, CS, p_surf, halo) else H_to_RL2_T2 = GV%H_to_RZ * GV%g_Earth endif -!$OMP parallel do default(none) shared(is,ie,js,je,CS,G,GV,US,h,nz,tv,p_surf) & -!$OMP private(fraz_col,T_fr_set,T_freeze,hc,ps) & -!$OMP firstprivate(pressure) !pressure might be set above, so should be firstprivate + !$OMP parallel do default(shared) private(fraz_col,T_fr_set,T_freeze,hc,ps) & + !$OMP firstprivate(pressure) ! pressure might be set above, so should be firstprivate do j=js,je ps(:) = 0.0 if (PRESENT(p_surf)) then ; do i=is,ie From bb73bb8f39bfee81263476c3dfaa0920448d41f5 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Tue, 14 Apr 2020 22:12:17 -0400 Subject: [PATCH 185/316] +(*)Rescaled pressures used to build coordinates Rescaled the pressures used to construct the rho, SLight, and Hycom coordinates. This change included passing in unit_scale_type arguments to several routines, and the addition of a call to get_param to potentially set the reference pressure for ALE configurations to something other than 2000 dbar at run time, as was already being done for other coordinates via tv%P_Ref. Because P_REF is read earlier by initialize_MOM, there are no changes to the MOM_parameter_doc files, but this could change answers in some cases with USE_REGRIDDING = True, P_Ref /= 2.0e7, and REGRIDDING_COORDINATE_MODE = RHO or SLIGHT. All answers are bitwise identical with the MOM6-examples test suite, but some public interfaces have new arguments. --- src/ALE/MOM_regridding.F90 | 63 +++++++++++++++++++------------- src/ALE/coord_hycom.F90 | 15 +++----- src/ALE/coord_rho.F90 | 27 ++++++-------- src/ALE/coord_slight.F90 | 37 +++++++++---------- src/framework/MOM_diag_remap.F90 | 2 +- 5 files changed, 73 insertions(+), 71 deletions(-) diff --git a/src/ALE/MOM_regridding.F90 b/src/ALE/MOM_regridding.F90 index bc290b3f94..1000ba0d32 100644 --- a/src/ALE/MOM_regridding.F90 +++ b/src/ALE/MOM_regridding.F90 @@ -84,7 +84,7 @@ module MOM_regridding !> Minimum thickness allowed when building the new grid through regridding [H ~> m or kg m-2]. real :: min_thickness - !> Reference pressure for potential density calculations [Pa] + !> Reference pressure for potential density calculations [R L2 T-2 ~> Pa] real :: ref_pressure = 2.e7 !> Weight given to old coordinate when blending between new and old grids [nondim] @@ -199,7 +199,7 @@ subroutine initialize_regridding(CS, GV, US, max_depth, param_file, mdl, coord_m logical :: tmpLogical, fix_haloclines, set_max, do_sum, main_parameters logical :: coord_is_state_dependent, ierr logical :: default_2018_answers, remap_answers_2018 - real :: filt_len, strat_tol, index_scale, tmpReal + real :: filt_len, strat_tol, index_scale, tmpReal, P_Ref real :: maximum_depth ! The maximum depth of the ocean [m] (not in Z). real :: dz_fixed_sfc, Rho_avg_depth, nlay_sfc_int real :: adaptTimeRatio, adaptZoom, adaptZoomCoeff, adaptBuoyCoeff, adaptAlpha @@ -513,11 +513,16 @@ subroutine initialize_regridding(CS, GV, US, max_depth, param_file, mdl, coord_m call initCoord(CS, GV, US, coord_mode) if (main_parameters .and. coord_is_state_dependent) then + call get_param(param_file, mdl, "P_REF", P_Ref, & + "The pressure that is used for calculating the coordinate "//& + "density. (1 Pa = 1e4 dbar, so 2e7 is commonly used.) "//& + "This is only used if USE_EOS and ENABLE_THERMODYNAMICS are true.", & + units="Pa", default=2.0e7, scale=US%kg_m3_to_R*US%m_s_to_L_T**2) call get_param(param_file, mdl, "REGRID_COMPRESSIBILITY_FRACTION", tmpReal, & "When interpolating potential density profiles we can add "//& "some artificial compressibility solely to make homogeneous "//& "regions appear stratified.", units="nondim", default=0.) - call set_regrid_params(CS, compress_fraction=tmpReal) + call set_regrid_params(CS, compress_fraction=tmpReal, ref_pressure=P_Ref) endif if (main_parameters) then @@ -865,7 +870,7 @@ subroutine regridding_main( remapCS, CS, G, GV, h, tv, h_new, dzInterface, frac_ 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 build_rho_grid( G, GV, G%US, h, tv, dzInterface, remapCS, CS ) call calc_h_new_by_dz(CS, G, GV, h, dzInterface, h_new) case ( REGRIDDING_ARBITRARY ) @@ -873,10 +878,10 @@ subroutine regridding_main( remapCS, CS, G, GV, h, tv, h_new, dzInterface, frac_ call calc_h_new_by_dz(CS, G, GV, h, dzInterface, h_new) case ( REGRIDDING_HYCOM1 ) - call build_grid_HyCOM1( G, GV, h, tv, h_new, dzInterface, CS ) + call build_grid_HyCOM1( G, GV, G%US, h, tv, h_new, dzInterface, CS ) case ( REGRIDDING_SLIGHT ) - call build_grid_SLight( G, GV, h, tv, dzInterface, CS ) + call build_grid_SLight( G, GV, G%US, h, tv, dzInterface, CS ) call calc_h_new_by_dz(CS, G, GV, h, dzInterface, h_new) case ( REGRIDDING_ADAPTIVE ) @@ -1317,7 +1322,7 @@ 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 ) +subroutine build_rho_grid( G, GV, US, h, tv, dzInterface, remapCS, CS ) !------------------------------------------------------------------------------ ! This routine builds a new grid based on a given set of target interface ! densities (these target densities are computed by taking the mean value @@ -1336,6 +1341,7 @@ subroutine build_rho_grid( G, GV, h, tv, dzInterface, remapCS, CS ) ! Arguments type(ocean_grid_type), intent(in) :: G !< Ocean grid structure type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamics structure real, dimension(SZI_(G),SZJ_(G), SZK_(GV)+1), intent(inout) :: dzInterface !< The change in interface depth @@ -1380,7 +1386,7 @@ subroutine build_rho_grid( G, GV, h, tv, dzInterface, remapCS, CS ) ! Local depth (G%bathyT is positive) nominalDepth = G%bathyT(i,j)*GV%Z_to_H - call build_rho_column(CS%rho_CS, nz, nominalDepth, h(i, j, :), & + call build_rho_column(CS%rho_CS, US, nz, nominalDepth, h(i, j, :), & tv%T(i, j, :), tv%S(i, j, :), tv%eqn_of_state, zNew, & h_neglect=h_neglect, h_neglect_edge=h_neglect_edge) @@ -1449,9 +1455,10 @@ 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, h_new, dzInterface, CS ) +subroutine build_grid_HyCOM1( G, GV, US, 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 + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Existing model thickness [H ~> m or kg m-2] type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamics structure type(regridding_CS), intent(in) :: CS !< Regridding control structure @@ -1462,7 +1469,8 @@ subroutine build_grid_HyCOM1( G, GV, h, tv, h_new, dzInterface, CS ) real, dimension(SZK_(GV)+1) :: z_col ! Source interface positions relative to the surface [H ~> m or kg m-2] real, dimension(CS%nk+1) :: z_col_new ! New interface positions relative to the surface [H ~> m or kg m-2] real, dimension(SZK_(GV)+1) :: dz_col ! The realized change in z_col [H ~> m or kg m-2] - real, dimension(SZK_(GV)) :: p_col ! Layer center pressure [Pa] + real, dimension(SZK_(GV)) :: p_col ! Layer center pressure [R L2 T-2 ~> Pa] + real :: ref_pres ! The reference pressure [R L2 T-2 ~> Pa] integer :: i, j, k, nki real :: depth real :: h_neglect, h_neglect_edge @@ -1489,12 +1497,12 @@ subroutine build_grid_HyCOM1( G, GV, h, tv, h_new, dzInterface, CS ) z_col(1) = 0. ! Work downward rather than bottom up do K = 1, GV%ke z_col(K+1) = z_col(K) + h(i,j,k) - 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 ) + p_col(k) = tv%P_Ref + CS%compressibility_fraction * & + ( 0.5 * ( z_col(K) + z_col(K+1) ) * (GV%H_to_RZ*GV%g_Earth) - tv%P_Ref ) enddo - 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, & + call build_hycom1_column(CS%hycom_CS, US, 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%Z_to_H, & h_neglect=h_neglect, h_neglect_edge=h_neglect_edge) @@ -1585,9 +1593,10 @@ 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, US, h, tv, dzInterface, CS) type(ocean_grid_type), intent(in) :: G !< Grid structure type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Existing model thickness [H ~> m or kg m-2] type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamics structure real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), intent(inout) :: dzInterface !< Changes in interface position @@ -1596,7 +1605,7 @@ subroutine build_grid_SLight(G, GV, h, tv, dzInterface, CS) real, dimension(SZK_(GV)+1) :: z_col ! Interface positions relative to the surface [H ~> m or kg m-2] real, dimension(SZK_(GV)+1) :: z_col_new ! Interface positions relative to the surface [H ~> m or kg m-2] real, dimension(SZK_(GV)+1) :: dz_col ! The realized change in z_col [H ~> m or kg m-2] - real, dimension(SZK_(GV)) :: p_col ! Layer center pressure [Pa] + real, dimension(SZK_(GV)) :: p_col ! Layer center pressure [R L2 T-2 ~> Pa] real :: depth integer :: i, j, k, nz real :: h_neglect, h_neglect_edge @@ -1622,11 +1631,11 @@ subroutine build_grid_SLight(G, GV, h, tv, dzInterface, CS) z_col(1) = 0. ! Work downward rather than bottom up do K=1,nz z_col(K+1) = z_col(K) + h(i,j,k) - 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 ) + p_col(k) = tv%P_Ref + CS%compressibility_fraction * & + ( 0.5 * ( z_col(K) + z_col(K+1) ) * (GV%H_to_RZ*GV%g_Earth) - tv%P_Ref ) enddo - call build_slight_column(CS%slight_CS, tv%eqn_of_state, GV%H_to_Pa, & + call build_slight_column(CS%slight_CS, US, tv%eqn_of_state, GV%H_to_RZ*GV%g_Earth, & GV%H_subroundoff, nz, depth, h(i, j, :), & tv%T(i, j, :), tv%S(i, j, :), p_col, z_col, z_col_new, & h_neglect=h_neglect, h_neglect_edge=h_neglect_edge) @@ -1962,7 +1971,7 @@ end function uniformResolution subroutine initCoord(CS, GV, US, 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 + !! See the documentation for regrid_consts !! for the recognized values. type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type @@ -1975,14 +1984,13 @@ subroutine initCoord(CS, GV, US, coord_mode) case (REGRIDDING_SIGMA) call init_coord_sigma(CS%sigma_CS, CS%nk, CS%coordinateResolution) case (REGRIDDING_RHO) - call init_coord_rho(CS%rho_CS, CS%nk, CS%ref_pressure, CS%target_density, CS%interp_CS, & - rho_scale=US%kg_m3_to_R) + call init_coord_rho(CS%rho_CS, CS%nk, CS%ref_pressure, CS%target_density, CS%interp_CS) case (REGRIDDING_HYCOM1) call init_coord_hycom(CS%hycom_CS, CS%nk, CS%coordinateResolution, CS%target_density, & - CS%interp_CS, rho_scale=US%kg_m3_to_R) + CS%interp_CS) case (REGRIDDING_SLIGHT) call init_coord_slight(CS%slight_CS, CS%nk, CS%ref_pressure, CS%target_density, & - CS%interp_CS, GV%m_to_H, rho_scale=US%kg_m3_to_R) + CS%interp_CS, GV%m_to_H) case (REGRIDDING_ADAPTIVE) call init_coord_adapt(CS%adapt_CS, CS%nk, CS%coordinateResolution, GV%m_to_H) end select @@ -2225,7 +2233,7 @@ end function getCoordinateShortName !> Can be used to set any of the parameters for MOM_regridding. subroutine set_regrid_params( CS, boundary_extrapolation, min_thickness, old_grid_weight, & interp_scheme, depth_of_time_filter_shallow, depth_of_time_filter_deep, & - compress_fraction, dz_min_surface, nz_fixed_surface, Rho_ML_avg_depth, & + compress_fraction, ref_pressure, dz_min_surface, nz_fixed_surface, Rho_ML_avg_depth, & nlay_ML_to_interior, fix_haloclines, halocline_filt_len, & halocline_strat_tol, integrate_downward_for_e, remap_answers_2018, & adaptTimeRatio, adaptZoom, adaptZoomCoeff, adaptBuoyCoeff, adaptAlpha, adaptDoMin, adaptDrho0) @@ -2237,7 +2245,9 @@ subroutine set_regrid_params( CS, boundary_extrapolation, min_thickness, old_gri 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 ~> m or kg m-2] real, optional, intent(in) :: depth_of_time_filter_deep !< Depth to end cubic [H ~> m or kg m-2] - real, optional, intent(in) :: compress_fraction !< Fraction of compressibility to add to potential density + real, optional, intent(in) :: compress_fraction !< Fraction of compressibility to add to potential density [nondim] + real, optional, intent(in) :: ref_pressure !< The reference pressure for density-dependent + !! coordinates [R L2 T-2 ~> Pa] real, optional, intent(in) :: dz_min_surface !< The fixed resolution in the topmost !! SLight_nkml_min layers [H ~> m or kg m-2] integer, optional, intent(in) :: nz_fixed_surface !< The number of fixed-thickness layers at the top of the model @@ -2283,6 +2293,7 @@ subroutine set_regrid_params( CS, boundary_extrapolation, min_thickness, old_gri if (present(min_thickness)) CS%min_thickness = min_thickness if (present(compress_fraction)) CS%compressibility_fraction = compress_fraction + if (present(ref_pressure)) CS%ref_pressure = ref_pressure if (present(integrate_downward_for_e)) CS%integrate_downward_for_e = integrate_downward_for_e if (present(remap_answers_2018)) CS%remap_answers_2018 = remap_answers_2018 diff --git a/src/ALE/coord_hycom.F90 b/src/ALE/coord_hycom.F90 index 1686ac51c9..bfcff9005c 100644 --- a/src/ALE/coord_hycom.F90 +++ b/src/ALE/coord_hycom.F90 @@ -4,6 +4,7 @@ module coord_hycom ! This file is part of MOM6. See LICENSE.md for the license. use MOM_error_handler, only : MOM_error, FATAL +use MOM_unit_scaling, only : unit_scale_type use MOM_EOS, only : EOS_type, calculate_density use regrid_interp, only : interp_CS_type, build_and_interpolate_grid @@ -21,9 +22,6 @@ module coord_hycom !> Nominal density of interfaces [R ~> kg m-3] real, allocatable, dimension(:) :: target_density - !> Density scaling factor [R m3 kg-1 ~> 1] - real :: kg_m3_to_R - !> Maximum depths of interfaces [H ~> m or kg m-2] real, allocatable, dimension(:) :: max_interface_depths @@ -39,13 +37,12 @@ module coord_hycom contains !> Initialise a hycom_CS with pointers to parameters -subroutine init_coord_hycom(CS, nk, coordinateResolution, target_density, interp_CS, rho_scale) +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(nk), intent(in) :: coordinateResolution !< Nominal near-surface resolution [Z ~> m] real, dimension(nk+1),intent(in) :: target_density !< Interface target densities [R ~> kg m-3] type(interp_CS_type), intent(in) :: interp_CS !< Controls for interpolation - real, optional, intent(in) :: rho_scale !< A dimensional scaling factor for target_density if (associated(CS)) call MOM_error(FATAL, "init_coord_hycom: CS already associated!") allocate(CS) @@ -56,7 +53,6 @@ subroutine init_coord_hycom(CS, nk, coordinateResolution, target_density, interp CS%coordinateResolution(:) = coordinateResolution(:) CS%target_density(:) = target_density(:) CS%interp_CS = interp_CS - CS%kg_m3_to_R = 1.0 ; if (present(rho_scale)) CS%kg_m3_to_R = rho_scale end subroutine init_coord_hycom @@ -100,16 +96,17 @@ subroutine set_hycom_params(CS, max_interface_depths, max_layer_thickness, inter end subroutine set_hycom_params !> Build a HyCOM coordinate column -subroutine build_hycom1_column(CS, eqn_of_state, nz, depth, h, T, S, p_col, & +subroutine build_hycom1_column(CS, US, eqn_of_state, nz, depth, h, T, S, p_col, & z_col, z_col_new, zScale, h_neglect, h_neglect_edge) type(hycom_CS), intent(in) :: CS !< Coordinate control structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type 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 [H ~> m or kg m-2]) real, dimension(nz), intent(in) :: T !< Temperature of column [degC] real, dimension(nz), intent(in) :: S !< Salinity of column [ppt] real, dimension(nz), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] - real, dimension(nz), intent(in) :: p_col !< Layer pressure [Pa] + real, dimension(nz), intent(in) :: p_col !< Layer pressure [R L2 T-2 ~> Pa] real, dimension(nz+1), intent(in) :: z_col !< Interface positions relative to the surface [H ~> m or kg m-2] real, dimension(CS%nk+1), intent(inout) :: z_col_new !< Absolute positions of interfaces [H ~> m or kg m-2] real, optional, intent(in) :: zScale !< Scaling factor from the input coordinate thicknesses in [Z ~> m] @@ -136,7 +133,7 @@ subroutine build_hycom1_column(CS, eqn_of_state, nz, depth, h, T, S, p_col, & z_scale = 1.0 ; if (present(zScale)) z_scale = zScale ! Work bottom recording potential density - call calculate_density(T, S, p_col, rho_col, 1, nz, eqn_of_state, scale=CS%kg_m3_to_R) + call calculate_density(T, S, p_col, rho_col, 1, nz, eqn_of_state, US=US) ! This ensures the potential density profile is monotonic ! although not necessarily single valued. do k = nz-1, 1, -1 diff --git a/src/ALE/coord_rho.F90 b/src/ALE/coord_rho.F90 index a78b1dd749..565656ecb0 100644 --- a/src/ALE/coord_rho.F90 +++ b/src/ALE/coord_rho.F90 @@ -5,6 +5,7 @@ module coord_rho use MOM_error_handler, only : MOM_error, FATAL use MOM_remapping, only : remapping_CS, remapping_core_h +use MOM_unit_scaling, only : unit_scale_type use MOM_EOS, only : EOS_type, calculate_density use regrid_interp, only : interp_CS_type, build_and_interpolate_grid, DEGREE_MAX @@ -19,7 +20,7 @@ module coord_rho !> Minimum thickness allowed for layers, often in [H ~> m or kg m-2] real :: min_thickness = 0. - !> Reference pressure for density calculations [Pa] + !> Reference pressure for density calculations [R L2 T-2 ~> Pa] real :: ref_pressure !> If true, integrate for interface positions from the top downward. @@ -29,9 +30,6 @@ module coord_rho !> Nominal density of interfaces [R ~> kg m-3] real, allocatable, dimension(:) :: target_density - !> Density scaling factor [R m3 kg-1 ~> 1] - real :: kg_m3_to_R - !> Interpolation control structure type(interp_CS_type) :: interp_CS end type rho_CS @@ -41,13 +39,12 @@ module coord_rho contains !> Initialise a rho_CS with pointers to parameters -subroutine init_coord_rho(CS, nk, ref_pressure, target_density, interp_CS, rho_scale) +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 !< Number of layers in the grid - real, intent(in) :: ref_pressure !< Coordinate reference pressure [Pa] + real, intent(in) :: ref_pressure !< Coordinate reference pressure [R L2 T-2 ~> Pa] real, dimension(:), intent(in) :: target_density !< Nominal density of interfaces [R ~> kg m-3] type(interp_CS_type), intent(in) :: interp_CS !< Controls for interpolation - real, optional, intent(in) :: rho_scale !< A dimensional scaling factor for target_density if (associated(CS)) call MOM_error(FATAL, "init_coord_rho: CS already associated!") allocate(CS) @@ -57,7 +54,6 @@ subroutine init_coord_rho(CS, nk, ref_pressure, target_density, interp_CS, rho_s CS%ref_pressure = ref_pressure CS%target_density(:) = target_density(:) CS%interp_CS = interp_CS - CS%kg_m3_to_R = 1.0 ; if (present(rho_scale)) CS%kg_m3_to_R = rho_scale end subroutine init_coord_rho @@ -92,9 +88,10 @@ end subroutine set_rho_params !! !! 1. Density profiles are calculated on the source grid. !! 2. Positions of target densities (for interfaces) are found by interpolation. -subroutine build_rho_column(CS, nz, depth, h, T, S, eqn_of_state, z_interface, & +subroutine build_rho_column(CS, US, nz, depth, h, T, S, eqn_of_state, z_interface, & h_neglect, h_neglect_edge) type(rho_CS), intent(in) :: CS !< coord_rho control structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type integer, intent(in) :: nz !< Number of levels on source grid (i.e. length of h, T, S) real, intent(in) :: depth !< Depth of ocean bottom (positive in m) real, dimension(nz), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] @@ -111,7 +108,7 @@ subroutine build_rho_column(CS, nz, depth, h, T, S, eqn_of_state, z_interface, & ! Local variables integer :: k, count_nonzero_layers integer, dimension(nz) :: mapping - real, dimension(nz) :: pres ! Pressures used to calculate density [Pa] + real, dimension(nz) :: pres ! Pressures used to calculate density [R L2 T-2 ~> Pa] real, dimension(nz) :: h_nv ! Thicknesses of non-vanishing layers [H ~> m or kg m-2] real, dimension(nz) :: densities ! Layer density [R ~> kg m-3] real, dimension(nz+1) :: xTmp ! Temporary positions [H ~> m or kg m-2] @@ -129,7 +126,7 @@ subroutine build_rho_column(CS, nz, depth, h, T, S, eqn_of_state, z_interface, & ! Compute densities on source column pres(:) = CS%ref_pressure - call calculate_density(T, S, pres, densities, 1, nz, eqn_of_state, scale=CS%kg_m3_to_R) + call calculate_density(T, S, pres, densities, 1, nz, eqn_of_state, US=US) do k = 1,count_nonzero_layers densities(k) = densities(mapping(k)) enddo @@ -188,9 +185,10 @@ end subroutine build_rho_column !! 4. T & S are remapped onto the new grid. !! 5. Return to step 1 until convergence or until the maximum number of !! iterations is reached, whichever comes first. -subroutine build_rho_column_iteratively(CS, remapCS, nz, depth, h, T, S, eqn_of_state, & +subroutine build_rho_column_iteratively(CS, US, remapCS, nz, depth, h, T, S, eqn_of_state, & zInterface, h_neglect, h_neglect_edge, dev_tol) type(rho_CS), intent(in) :: CS !< Regridding control structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(remapping_CS), intent(in) :: remapCS !< Remapping parameters and options integer, intent(in) :: nz !< Number of levels real, intent(in) :: depth !< Depth of ocean bottom [Z ~> m] @@ -211,7 +209,7 @@ subroutine build_rho_column_iteratively(CS, remapCS, nz, depth, h, T, S, eqn_of_ ! Local variables real, dimension(nz+1) :: x0, x1, xTmp ! Temporary interface heights [Z ~> m] - real, dimension(nz) :: pres ! The pressure used in the equation of state [Pa]. + real, dimension(nz) :: pres ! The pressure used in the equation of state [R L2 T-2 ~> Pa]. real, dimension(nz) :: densities ! Layer densities [R ~> kg m-3] real, dimension(nz) :: T_tmp, S_tmp ! A temporary profile of temperature [degC] and salinity [ppt]. real, dimension(nz) :: Tmp ! A temporary variable holding a remapped variable. @@ -252,8 +250,7 @@ subroutine build_rho_column_iteratively(CS, remapCS, nz, depth, h, T, S, eqn_of_ enddo ! Compute densities within current water column - call calculate_density( T_tmp, S_tmp, pres, densities, & - 1, nz, eqn_of_state, scale=CS%kg_m3_to_R) + call calculate_density( T_tmp, S_tmp, pres, densities, 1, nz, eqn_of_state, US=US) do k = 1,count_nonzero_layers densities(k) = densities(mapping(k)) diff --git a/src/ALE/coord_slight.F90 b/src/ALE/coord_slight.F90 index 30f2597090..89c78d6c64 100644 --- a/src/ALE/coord_slight.F90 +++ b/src/ALE/coord_slight.F90 @@ -4,6 +4,7 @@ module coord_slight ! This file is part of MOM6. See LICENSE.md for the license. use MOM_error_handler, only : MOM_error, FATAL +use MOM_unit_scaling, only : unit_scale_type use MOM_EOS, only : EOS_type, calculate_compress use MOM_EOS, only : calculate_density, calculate_density_derivs use regrid_interp, only : interp_CS_type, regridding_set_ppolys @@ -20,7 +21,7 @@ module coord_slight !> Minimum thickness allowed when building the new grid through regridding [H ~> m or kg m-2] real :: min_thickness - !> Reference pressure for potential density calculations [Pa] + !> Reference pressure for potential density calculations [R L2 T-2 ~> Pa] real :: ref_pressure !> Fraction (between 0 and 1) of compressibility to add to potential density @@ -54,9 +55,6 @@ module coord_slight !> Nominal density of interfaces [R ~> kg m-3]. real, allocatable, dimension(:) :: target_density - !> Density scaling factor [R m3 kg-1 ~> 1] - real :: kg_m3_to_R - !> Maximum depths of interfaces [H ~> m or kg m-2]. real, allocatable, dimension(:) :: max_interface_depths @@ -72,14 +70,13 @@ module coord_slight contains !> Initialise a slight_CS with pointers to parameters -subroutine init_coord_slight(CS, nk, ref_pressure, target_density, interp_CS, m_to_H, rho_scale) +subroutine init_coord_slight(CS, nk, ref_pressure, target_density, interp_CS, m_to_H) type(slight_CS), pointer :: CS !< Unassociated pointer to hold the control structure integer, intent(in) :: nk !< Number of layers in the grid - real, intent(in) :: ref_pressure !< Coordinate reference pressure [Pa] + real, intent(in) :: ref_pressure !< Coordinate reference pressure [R L2 T-2 ~> Pa] real, dimension(:), intent(in) :: target_density !< Nominal density of interfaces [R ~> kg m-3] type(interp_CS_type), intent(in) :: interp_CS !< Controls for interpolation real, optional, intent(in) :: m_to_H !< A conversion factor from m to the units of thicknesses - real, optional, intent(in) :: rho_scale !< A dimensional scaling factor for target_density real :: m_to_H_rescale ! A unit conversion factor. @@ -101,7 +98,6 @@ subroutine init_coord_slight(CS, nk, ref_pressure, target_density, interp_CS, m_ CS%dz_ml_min = 1.0 * m_to_H_rescale CS%halocline_filter_length = 2.0 * m_to_H_rescale CS%halocline_strat_tol = 0.25 ! Nondim. - CS%kg_m3_to_R = 1.0 ; if (present(rho_scale)) CS%kg_m3_to_R = rho_scale end subroutine init_coord_slight @@ -182,19 +178,21 @@ subroutine set_slight_params(CS, max_interface_depths, max_layer_thickness, & end subroutine set_slight_params !> Build a SLight coordinate column -subroutine build_slight_column(CS, eqn_of_state, H_to_Pa, H_subroundoff, & +subroutine build_slight_column(CS, US, eqn_of_state, H_to_pres, H_subroundoff, & nz, depth, h_col, T_col, S_col, p_col, z_col, z_col_new, & h_neglect, h_neglect_edge) type(slight_CS), intent(in) :: CS !< Coordinate control structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(EOS_type), pointer :: eqn_of_state !< Equation of state structure - real, intent(in) :: H_to_Pa !< GV%H_to_Pa + real, intent(in) :: H_to_pres !< A conversion factor from thicknesses to + !! scaled pressure [R L2 T-2 H-1 ~> Pa m-1 or Pa m2 kg-1] real, intent(in) :: H_subroundoff !< GV%H_subroundoff integer, intent(in) :: nz !< Number of levels real, intent(in) :: depth !< Depth of ocean bottom (positive [H ~> m or kg m-2]) real, dimension(nz), intent(in) :: T_col !< T for column real, dimension(nz), intent(in) :: S_col !< S for column real, dimension(nz), intent(in) :: h_col !< Layer thicknesses [H ~> m or kg m-2] - real, dimension(nz), intent(in) :: p_col !< Layer quantities + real, dimension(nz), intent(in) :: p_col !< Layer center pressure [R L2 T-2 ~> Pa] real, dimension(nz+1), intent(in) :: z_col !< Interface positions relative to the surface [H ~> m or kg m-2] real, dimension(nz+1), intent(inout) :: z_col_new !< Absolute positions of interfaces [H ~> m or kg m-2] real, optional, intent(in) :: h_neglect !< A negligibly small width for the purpose of @@ -208,7 +206,7 @@ subroutine build_slight_column(CS, eqn_of_state, H_to_Pa, H_subroundoff, & real, dimension(nz+1) :: T_int, S_int ! Temperature [degC] and salinity [ppt] interpolated to interfaces. real, dimension(nz+1) :: rho_tmp ! A temporary density [R ~> kg m-3] real, dimension(nz+1) :: drho_dp ! The partial derivative of density with pressure [kg m-3 Pa-1] - real, dimension(nz+1) :: p_IS, p_R + real, dimension(nz+1) :: p_IS, p_R ! Pressures [R L2 T-2 ~> Pa] real, dimension(nz+1) :: drhoIS_dT ! The partial derivative of in situ density with temperature ! in [R degC-1 ~> kg m-3 degC-1] real, dimension(nz+1) :: drhoIS_dS ! The partial derivative of in situ density with salinity @@ -254,8 +252,7 @@ subroutine build_slight_column(CS, eqn_of_state, H_to_Pa, H_subroundoff, & dz = (z_col(nz+1) - z_col(1)) / real(nz) do K=2,nz ; z_col_new(K) = z_col(1) + dz*real(K-1) ; enddo else - call calculate_density(T_col, S_col, p_col, rho_col, 1, nz, & - eqn_of_state, scale=CS%kg_m3_to_R) + call calculate_density(T_col, S_col, p_col, rho_col, 1, nz, eqn_of_state, US=US) ! Find the locations of the target potential densities, flagging ! locations in apparently unstable regions as not reliable. @@ -371,23 +368,23 @@ subroutine build_slight_column(CS, eqn_of_state, H_to_Pa, H_subroundoff, & T_int(1) = T_f(1) ; S_int(1) = S_f(1) do K=2,nz T_int(K) = 0.5*(T_f(k-1) + T_f(k)) ; S_int(K) = 0.5*(S_f(k-1) + S_f(k)) - p_IS(K) = z_col(K) * H_to_Pa + p_IS(K) = z_col(K) * H_to_pres p_R(K) = CS%ref_pressure + CS%compressibility_fraction * ( p_IS(K) - CS%ref_pressure ) enddo T_int(nz+1) = T_f(nz) ; S_int(nz+1) = S_f(nz) - p_IS(nz+1) = z_col(nz+1) * H_to_Pa + p_IS(nz+1) = z_col(nz+1) * H_to_pres call calculate_density_derivs(T_int, S_int, p_IS, drhoIS_dT, drhoIS_dS, 2, nz-1, & - eqn_of_state, scale=CS%kg_m3_to_R) + eqn_of_state, US) call calculate_density_derivs(T_int, S_int, p_R, drhoR_dT, drhoR_dS, 2, nz-1, & - eqn_of_state, scale=CS%kg_m3_to_R) + eqn_of_state, US) if (CS%compressibility_fraction > 0.0) then - call calculate_compress(T_int, S_int, p_R, rho_tmp, drho_dp, 2, nz-1, & + call calculate_compress(T_int, S_int, US%RL2_T2_to_Pa*p_R(:), rho_tmp, drho_dp, 2, nz-1, & eqn_of_state) else do K=2,nz ; drho_dp(K) = 0.0 ; enddo endif - H_to_cPa = CS%compressibility_fraction*CS%kg_m3_to_R*H_to_Pa + H_to_cPa = CS%compressibility_fraction * H_to_pres * US%L_T_to_m_s**2 strat_rat(1) = 1.0 do K=2,nz drIS = drhoIS_dT(K) * (T_f(k) - T_f(k-1)) + & diff --git a/src/framework/MOM_diag_remap.F90 b/src/framework/MOM_diag_remap.F90 index cadd74950a..83a7ce207c 100644 --- a/src/framework/MOM_diag_remap.F90 +++ b/src/framework/MOM_diag_remap.F90 @@ -327,7 +327,7 @@ subroutine diag_remap_update(remap_cs, G, GV, US, h, T, S, eqn_of_state) GV%Z_to_H*G%bathyT(i,j), sum(h(i,j,:)), zInterfaces) elseif (remap_cs%vertical_coord == coordinateMode('RHO')) then !### I think that the conversion factor in the 2nd line should be GV%Z_to_H - call build_rho_column(get_rho_CS(remap_cs%regrid_cs), G%ke, & + call build_rho_column(get_rho_CS(remap_cs%regrid_cs), US, G%ke, & US%Z_to_m*G%bathyT(i,j), h(i,j,:), T(i,j,:), S(i,j,:), & eqn_of_state, zInterfaces, h_neglect, h_neglect_edge) elseif (remap_cs%vertical_coord == coordinateMode('SLIGHT')) then From 4182ad23cace2f9d0d65666db948cd72a556f917 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 15 Apr 2020 03:53:48 -0400 Subject: [PATCH 186/316] +Add optional US arg to calculate_compress Added a new optional unit_scale_type argument to the calculate_compress to trigger dimensional rescaling of their input and output variables. Also use this new argument in calls to calculate_compress from build_slight_column and rescaled internal variables in the same routine. All answers are bitwise identical, but there is a new optional argument to a public interface. --- src/ALE/coord_slight.F90 | 30 +++++++++--------- src/equation_of_state/MOM_EOS.F90 | 52 +++++++++++++++++++++++-------- 2 files changed, 54 insertions(+), 28 deletions(-) diff --git a/src/ALE/coord_slight.F90 b/src/ALE/coord_slight.F90 index 89c78d6c64..000315bae8 100644 --- a/src/ALE/coord_slight.F90 +++ b/src/ALE/coord_slight.F90 @@ -205,7 +205,7 @@ subroutine build_slight_column(CS, US, eqn_of_state, H_to_pres, H_subroundoff, & logical, dimension(nz+1) :: reliable ! If true, this interface is in a reliable position. real, dimension(nz+1) :: T_int, S_int ! Temperature [degC] and salinity [ppt] interpolated to interfaces. real, dimension(nz+1) :: rho_tmp ! A temporary density [R ~> kg m-3] - real, dimension(nz+1) :: drho_dp ! The partial derivative of density with pressure [kg m-3 Pa-1] + real, dimension(nz+1) :: drho_dp ! The partial derivative of density with pressure [T2 L-2 ~> kg m-3 Pa-1] real, dimension(nz+1) :: p_IS, p_R ! Pressures [R L2 T-2 ~> Pa] real, dimension(nz+1) :: drhoIS_dT ! The partial derivative of in situ density with temperature ! in [R degC-1 ~> kg m-3 degC-1] @@ -216,19 +216,20 @@ subroutine build_slight_column(CS, US, eqn_of_state, H_to_pres, H_subroundoff, & real, dimension(nz+1) :: drhoR_dS ! The partial derivative of reference density with salinity ! in [R ppt-1 ~> kg m-3 ppt-1] real, dimension(nz+1) :: strat_rat - real :: H_to_cPa + real :: H_to_cPa ! A conversion factor from thicknesses to the compressibility fraction times + ! the units of pressure [R L2 T-2 H-1 ~> Pa m-1 or Pa m2 kg-1] real :: drIS, drR ! In situ and reference density differences [R ~> kg m-3] - real :: Fn_now, I_HStol, Fn_zero_val - real :: z_int_unst - real :: dz ! A uniform layer thickness in very shallow water [H ~> m or kg m-2]. - real :: dz_ur ! The total thickness of an unstable region [H ~> m or kg m-2]. + real :: Fn_now, I_HStol, Fn_zero_val ! Nondimensional variables [nondim] + real :: z_int_unst ! The depth where the stratification allows the interior grid to start [H ~> m or kg m-2] + real :: dz ! A uniform layer thickness in very shallow water [H ~> m or kg m-2]. + real :: dz_ur ! The total thickness of an unstable region [H ~> m or kg m-2]. real :: wgt, cowgt ! A weight and its complement [nondim]. - real :: rho_ml_av ! The average potential density in a near-surface region [R ~> kg m-3]. - real :: H_ml_av ! A thickness to try to use in taking the near-surface average [H ~> m or kg m-2]. - real :: rho_x_z ! A cumulative integral of a density [R H ~> kg m-2 or kg2 m-5]. - real :: z_wt ! The thickness actually used in taking the near-surface average [H ~> m or kg m-2]. - real :: k_interior ! The (real) value of k where the interior grid starts. - real :: k_int2 ! The (real) value of k where the interior grid starts. + real :: rho_ml_av ! The average potential density in a near-surface region [R ~> kg m-3]. + real :: H_ml_av ! A thickness to try to use in taking the near-surface average [H ~> m or kg m-2]. + real :: rho_x_z ! A cumulative integral of a density [R H ~> kg m-2 or kg2 m-5]. + real :: z_wt ! The thickness actually used in taking the near-surface average [H ~> m or kg m-2]. + real :: k_interior ! The (real) value of k where the interior grid starts [nondim]. + real :: k_int2 ! The (real) value of k where the interior grid starts [nondim]. real :: z_interior ! The depth where the interior grid starts [H ~> m or kg m-2]. real :: z_ml_fix ! The depth at which the fixed-thickness near-surface layers end [H ~> m or kg m-2]. real :: dz_dk ! The thickness of layers between the fixed-thickness @@ -378,13 +379,12 @@ subroutine build_slight_column(CS, US, eqn_of_state, H_to_pres, H_subroundoff, & call calculate_density_derivs(T_int, S_int, p_R, drhoR_dT, drhoR_dS, 2, nz-1, & eqn_of_state, US) if (CS%compressibility_fraction > 0.0) then - call calculate_compress(T_int, S_int, US%RL2_T2_to_Pa*p_R(:), rho_tmp, drho_dp, 2, nz-1, & - eqn_of_state) + call calculate_compress(T_int, S_int, p_R(:), rho_tmp, drho_dp, 2, nz-1, eqn_of_state, US) else do K=2,nz ; drho_dp(K) = 0.0 ; enddo endif - H_to_cPa = CS%compressibility_fraction * H_to_pres * US%L_T_to_m_s**2 + H_to_cPa = CS%compressibility_fraction * H_to_pres strat_rat(1) = 1.0 do K=2,nz drIS = drhoIS_dT(K) * (T_f(k) - T_f(k-1)) + & diff --git a/src/equation_of_state/MOM_EOS.F90 b/src/equation_of_state/MOM_EOS.F90 index c1fd5fd42f..4730d92807 100644 --- a/src/equation_of_state/MOM_EOS.F90 +++ b/src/equation_of_state/MOM_EOS.F90 @@ -394,6 +394,7 @@ subroutine calc_spec_vol_US(T, S, pressure, specvol, start, npts, EOS, US, spv_r real, optional, intent(in) :: scale !< A multiplicative factor by which to scale specific !! volume in combination with scaling given by US [various] + ! Local variables real, dimension(size(pressure)) :: pres ! Pressure converted to [Pa] real :: spv_reference ! spv_ref converted to [m3 kg-1] real :: spv_scale ! A factor to convert specific volume from m3 kg-1 to the desired units [kg R-1 m-3 ~> 1] @@ -995,21 +996,35 @@ subroutine calc_spec_vol_derivs_HI_1d(T, S, pressure, dSV_dT, dSV_dS, HI, EOS, U end subroutine calc_spec_vol_derivs_HI_1d -!> Calls the appropriate subroutine to calculate the density and compressibility for 1-D array inputs. -subroutine calculate_compress_array(T, S, pressure, rho, drho_dp, start, npts, EOS) +!> Calls the appropriate subroutine to calculate the density and compressibility for 1-D array +!! inputs. If US is present, the units of the inputs and outputs are rescaled. +subroutine calculate_compress_array(T, S, press, rho, drho_dp, start, npts, EOS, US) 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(inout) :: rho !< In situ density [kg m-3] + real, dimension(:), intent(in) :: press !< Pressure [Pa] or [R L2 T-2 ~> Pa] + real, dimension(:), intent(inout) :: rho !< In situ density [kg m-3] or [R ~> kg m-3] real, dimension(:), intent(inout) :: drho_dp !< The partial derivative of density with pressure - !! (also the inverse of the square of sound speed) [s2 m-2] + !! (also the inverse of the square of sound speed) + !! [s2 m-2] or [T2 L-2] 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 + type(unit_scale_type), optional, intent(in) :: US !< A dimensional unit scaling type + + ! Local variables + real, dimension(size(press)) :: pressure ! Pressure converted to [Pa] + integer :: i, is, ie if (.not.associated(EOS)) call MOM_error(FATAL, & "calculate_compress called with an unassociated EOS_type EOS.") + is = start ; ie = is + npts - 1 + if (present(US)) then + do i=is,ie ; pressure(i) = US%RL2_T2_to_Pa * press(i) ; enddo + else + do i=is,ie ; pressure(i) = press(i) ; enddo + endif + select case (EOS%form_of_EOS) case (EOS_LINEAR) call calculate_compress_linear(T, S, pressure, rho, drho_dp, start, npts, & @@ -1026,18 +1041,29 @@ subroutine calculate_compress_array(T, S, pressure, rho, drho_dp, start, npts, E call MOM_error(FATAL, "calculate_compress: EOS%form_of_EOS is not valid.") end select + if (present(US)) then + if (US%kg_m3_to_R /= 1.0) then ; do i=is,ie + rho(i) = US%kg_m3_to_R * rho(i) + enddo ; endif + if (US%L_T_to_m_s /= 1.0) then ; do i=is,ie + drho_dp(i) = US%L_T_to_m_s**2 * drho_dp(i) + enddo ; endif + endif + end subroutine calculate_compress_array !> Calculate density and compressibility for a scalar. This just promotes the scalar to an array -!! with a singleton dimension and calls calculate_compress_array -subroutine calculate_compress_scalar(T, S, pressure, rho, drho_dp, EOS) +!! with a singleton dimension and calls calculate_compress_array. If US is present, the units of +!! the inputs and outputs are rescaled. +subroutine calculate_compress_scalar(T, S, pressure, rho, drho_dp, EOS, US) real, intent(in) :: T !< Potential temperature referenced to the surface [degC] real, intent(in) :: S !< Salinity [ppt] - real, intent(in) :: pressure !< Pressure [Pa] - real, intent(out) :: rho !< In situ density [kg m-3] - real, intent(out) :: drho_dp !< The partial derivative of density with pressure - !! (also the inverse of the square of sound speed) [s2 m-2] + real, intent(in) :: pressure !< Pressure [Pa] or [R L2 T-2 ~> Pa] + real, intent(out) :: rho !< In situ density [kg m-3] or [R ~> kg m-3] + real, intent(out) :: drho_dp !< The partial derivative of density with pressure (also the + !! inverse of the square of sound speed) [s2 m-2] or [T2 L-2] type(EOS_type), pointer :: EOS !< Equation of state structure + type(unit_scale_type), optional, intent(in) :: US !< A dimensional unit scaling type real, dimension(1) :: Ta, Sa, pa, rhoa, drho_dpa @@ -1045,7 +1071,7 @@ subroutine calculate_compress_scalar(T, S, pressure, rho, drho_dp, EOS) "calculate_compress called with an unassociated EOS_type EOS.") Ta(1) = T ; Sa(1) = S; pa(1) = pressure - call calculate_compress_array(Ta, Sa, pa, rhoa, drho_dpa, 1, 1, EOS) + call calculate_compress_array(Ta, Sa, pa, rhoa, drho_dpa, 1, 1, EOS, US) rho = rhoa(1) ; drho_dp = drho_dpa(1) end subroutine calculate_compress_scalar @@ -1076,7 +1102,7 @@ subroutine int_specific_vol_dp(T, S, p_t, p_b, alpha_ref, HI, EOS, & type(EOS_type), pointer :: EOS !< Equation of state structure real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & intent(inout) :: dza !< The change in the geopotential anomaly across - !! the layer [T-2 ~> m2 s-2] or [m2 s-2] + !! the layer [L2 T-2 ~> m2 s-2] or [m2 s-2] real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & optional, intent(inout) :: intp_dza !< The integral in pressure through the layer of the !! geopotential anomaly relative to the anomaly at the bottom of the From b84b2d35fa34fa74344cf7c6b9132f7f319cd3af Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 15 Apr 2020 03:57:18 -0400 Subject: [PATCH 187/316] Rescaled variables in convert_thickness Rescaled internal variables in convert_thickness, including pressures and densities, for dimensional consistency testing and code simplification. All answers are bitwise identical. --- .../MOM_state_initialization.F90 | 45 +++++++++---------- 1 file changed, 21 insertions(+), 24 deletions(-) diff --git a/src/initialization/MOM_state_initialization.F90 b/src/initialization/MOM_state_initialization.F90 index 3cdcb5bcfd..2efceb5991 100644 --- a/src/initialization/MOM_state_initialization.F90 +++ b/src/initialization/MOM_state_initialization.F90 @@ -932,27 +932,26 @@ subroutine convert_thickness(h, G, GV, US, tv) !! thermodynamic variables ! Local variables real, dimension(SZI_(G),SZJ_(G)) :: & - p_top, p_bot - real :: dz_geo(SZI_(G),SZJ_(G)) ! The change in geopotential height - ! across a layer [m2 s-2]. - real :: rho(SZI_(G)) - real :: I_gEarth - real :: Hm_rho_to_Pa ! A conversion factor from the input geometric thicknesses times the - ! layer densities into Pa [Pa m3 H-1 kg-1 ~> s-2 m2 or s-2 m5 kg-1]. - logical :: Boussinesq + p_top, p_bot ! Pressure at the interfaces above and below a layer [R L2 T-2 ~> Pa] + real :: dz_geo(SZI_(G),SZJ_(G)) ! The change in geopotential height across a layer [L2 T-2 ~> m2 s-2] + real :: rho(SZI_(G)) ! The in situ density [R ~> kg m-3] + real :: I_gEarth ! Unit conversion factors divided by the gravitational acceleration + ! [H T2 R-1 L-2 ~> s2 m2 kg-1 or s2 m-1] + real :: HR_to_pres ! A conversion factor from the input geometric thicknesses times the layer + ! densities into pressure units [L2 T-2 H-1 ~> m s-2 or m4 kg-1 s-2]. integer :: i, j, k, is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz integer :: itt, max_itt 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 max_itt = 10 - Boussinesq = GV%Boussinesq - I_gEarth = 1.0 / (GV%mks_g_Earth) - Hm_rho_to_Pa = GV%mks_g_Earth * GV%H_to_m ! = GV%H_to_Pa / (US%R_to_kg_m3*GV%Rho0) - if (Boussinesq) then + if (GV%Boussinesq) then call MOM_error(FATAL,"Not yet converting thickness with Boussinesq approx.") else + I_gEarth = GV%RZ_to_H / GV%g_Earth + HR_to_pres = GV%g_Earth * GV%H_to_Z + if (associated(tv%eqn_of_state)) then do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 p_bot(i,j) = 0.0 ; p_top(i,j) = 0.0 @@ -960,31 +959,29 @@ subroutine convert_thickness(h, G, GV, US, tv) do k=1,nz do j=js,je do i=is,ie ; p_top(i,j) = p_bot(i,j) ; enddo - call calculate_density(tv%T(:,j,k), tv%S(:,j,k), p_top(:,j), rho, & - is, ie-is+1, tv%eqn_of_state) + call calculate_density(tv%T(:,j,k), tv%S(:,j,k), p_top(:,j), rho, G%HI, & + tv%eqn_of_state, US) do i=is,ie - p_bot(i,j) = p_top(i,j) + Hm_rho_to_Pa * (h(i,j,k) * rho(i)) + p_bot(i,j) = p_top(i,j) + HR_to_pres * (h(i,j,k) * rho(i)) enddo enddo do itt=1,max_itt - call int_specific_vol_dp(tv%T(:,:,k), tv%S(:,:,k), p_top, p_bot, & - 0.0, G%HI, tv%eqn_of_state, dz_geo) + call int_specific_vol_dp(tv%T(:,:,k), tv%S(:,:,k), p_top, p_bot, 0.0, G%HI, & + tv%eqn_of_state, dz_geo, US=US) if (itt < max_itt) then ; do j=js,je - call calculate_density(tv%T(:,j,k), tv%S(:,j,k), p_bot(:,j), rho, & - is, ie-is+1, tv%eqn_of_state) + call calculate_density(tv%T(:,j,k), tv%S(:,j,k), p_bot(:,j), rho, G%HI, & + tv%eqn_of_state, US) ! Use Newton's method to correct the bottom value. - ! The hydrostatic equation is linear to such a - ! high degree that no bounds-checking is needed. + ! The hydrostatic equation is sufficiently linear that no bounds-checking is needed. do i=is,ie - p_bot(i,j) = p_bot(i,j) + rho(i) * & - (Hm_rho_to_Pa*h(i,j,k) - dz_geo(i,j)) + p_bot(i,j) = p_bot(i,j) + rho(i) * (HR_to_pres*h(i,j,k) - dz_geo(i,j)) enddo enddo ; endif enddo do j=js,je ; do i=is,ie - h(i,j,k) = (p_bot(i,j) - p_top(i,j)) * GV%kg_m2_to_H * I_gEarth + h(i,j,k) = (p_bot(i,j) - p_top(i,j)) * I_gEarth enddo ; enddo enddo else From da120120cba4df66f1212f455878d8105185a5ca Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 15 Apr 2020 04:00:15 -0400 Subject: [PATCH 188/316] Minor cleanup related to pressure rescaling Minor refactoring of variables related to pressure rescaling and some cleanup of comments. All answers are bitwise identical. --- src/core/MOM_dynamics_split_RK2.F90 | 8 ++++---- src/parameterizations/vertical/MOM_energetic_PBL.F90 | 4 ++-- 2 files changed, 6 insertions(+), 6 deletions(-) diff --git a/src/core/MOM_dynamics_split_RK2.F90 b/src/core/MOM_dynamics_split_RK2.F90 index e47e84b792..23b40e3171 100644 --- a/src/core/MOM_dynamics_split_RK2.F90 +++ b/src/core/MOM_dynamics_split_RK2.F90 @@ -305,7 +305,8 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, Time_local, dt, forces, p_s ! u_old_rad_OBC and v_old_rad_OBC are the starting velocities, which are ! saved for use in the Flather open boundary condition code [L T-1 ~> m s-1]. - real :: Pa_to_eta ! A factor that converts pressures to the units of eta. + real :: pres_to_eta ! A factor that converts pressures to the units of eta + ! [H T2 R-1 L-2 ~> m Pa-1 or kg m-2 Pa-1] real, pointer, dimension(:,:) :: & p_surf => NULL(), eta_PF_start => NULL(), & taux_bot => NULL(), tauy_bot => NULL(), & @@ -412,11 +413,10 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, Time_local, dt, forces, p_s call PressureForce(h, tv, CS%PFu, CS%PFv, G, GV, US, CS%PressureForce_CSp, & CS%ALE_CSp, p_surf, CS%pbce, CS%eta_PF) if (dyn_p_surf) then - Pa_to_eta = US%RL2_T2_to_Pa / GV%H_to_Pa + pres_to_eta = 1.0 / (GV%g_Earth * GV%H_to_RZ) !$OMP parallel do default(shared) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - eta_PF_start(i,j) = CS%eta_PF(i,j) - Pa_to_eta * & - (p_surf_begin(i,j) - p_surf_end(i,j)) + eta_PF_start(i,j) = CS%eta_PF(i,j) - pres_to_eta * (p_surf_begin(i,j) - p_surf_end(i,j)) enddo ; enddo endif call cpu_clock_end(id_clock_pres) diff --git a/src/parameterizations/vertical/MOM_energetic_PBL.F90 b/src/parameterizations/vertical/MOM_energetic_PBL.F90 index 7ba477466e..8b5da8565b 100644 --- a/src/parameterizations/vertical/MOM_energetic_PBL.F90 +++ b/src/parameterizations/vertical/MOM_energetic_PBL.F90 @@ -658,7 +658,7 @@ subroutine ePBL_column(h, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, B_flux, abs real :: h_neglect ! A thickness that is so small it is usually lost ! in roundoff and can be neglected [H ~> m or kg m-2]. real :: dMass ! The mass per unit area within a layer [Z R ~> kg m-2]. - real :: dPres ! The hydrostatic pressure change across a layer [R Z2 T-2 ~> kg m-1 s-2 = Pa = J m-3]. + real :: dPres ! The hydrostatic pressure change across a layer [R Z2 T-2 ~> Pa = J m-3]. real :: dMKE_max ! The maximum amount of mean kinetic energy that could be ! converted to turbulent kinetic energy if the velocity in ! the layer below an interface were homogenized with all of @@ -805,7 +805,7 @@ subroutine ePBL_column(h, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, B_flux, abs pres_Z(1) = 0.0 do k=1,nz dMass = GV%H_to_RZ * h(k) - dPres = US%L_to_Z**2 * GV%g_Earth * dMass ! Equivalent to GV%H_to_Pa * h(k) with rescaling + dPres = US%L_to_Z**2 * GV%g_Earth * dMass dT_to_dPE(k) = (dMass * (pres_Z(K) + 0.5*dPres)) * dSV_dT(k) dS_to_dPE(k) = (dMass * (pres_Z(K) + 0.5*dPres)) * dSV_dS(k) dT_to_dColHt(k) = dMass * dSV_dT(k) From 87054b46472399169ac7fcba89cf095e5494c93d Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 15 Apr 2020 05:36:57 -0400 Subject: [PATCH 189/316] Added an omitted dOxygen comment --- src/equation_of_state/MOM_EOS.F90 | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/src/equation_of_state/MOM_EOS.F90 b/src/equation_of_state/MOM_EOS.F90 index 4730d92807..9788c84338 100644 --- a/src/equation_of_state/MOM_EOS.F90 +++ b/src/equation_of_state/MOM_EOS.F90 @@ -73,6 +73,7 @@ module MOM_EOS calculate_density_derivs_HI_1d end interface calculate_density_derivs +!> Calculate the derivatives of specific volume with temperature and salinity from T, S, and P interface calculate_specific_vol_derivs module procedure calculate_spec_vol_derivs_array, calc_spec_vol_derivs_US, calc_spec_vol_derivs_HI_1d end interface calculate_specific_vol_derivs @@ -954,7 +955,8 @@ subroutine calc_spec_vol_derivs_US(T, S, pressure, dSV_dT, dSV_dS, start, npts, end subroutine calc_spec_vol_derivs_US -!> Calls the appropriate subroutine to calculate specific volume derivatives for an array. +!> Calls the appropriate subroutine to calculate specific volume derivatives for array inputs +!! using array extents determined from a hor_index_type.. subroutine calc_spec_vol_derivs_HI_1d(T, S, pressure, dSV_dT, dSV_dS, HI, EOS, US, halo) type(hor_index_type), intent(in) :: HI !< The horizontal index structure real, dimension(HI%isd:HI%ied), intent(in) :: T !< Potential temperature referenced to the surface [degC] From 77b6b74714b5df97c3e04ba4d1b00bc672d357d2 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 15 Apr 2020 05:43:39 -0400 Subject: [PATCH 190/316] (*)Set loop bounds in calculate_density calls Explicitly set loop bounds in some calculate_density calls with halos that are only set around velocity points to avoid errors with non-symmetric memory. All answers are bitwise identical in test cases, and this should fix a problem that was detected by the automated testing. --- src/core/MOM_PressureForce_Montgomery.F90 | 46 ++++++++++--------- src/core/MOM_PressureForce_analytic_FV.F90 | 26 ++++++----- src/core/MOM_PressureForce_blocked_AFV.F90 | 26 ++++++----- .../vertical/MOM_set_viscosity.F90 | 7 +-- 4 files changed, 57 insertions(+), 48 deletions(-) diff --git a/src/core/MOM_PressureForce_Montgomery.F90 b/src/core/MOM_PressureForce_Montgomery.F90 index b7291b71b2..0d8cf27dad 100644 --- a/src/core/MOM_PressureForce_Montgomery.F90 +++ b/src/core/MOM_PressureForce_Montgomery.F90 @@ -124,11 +124,12 @@ subroutine PressureForce_Mont_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, pb real :: alpha_Lay(SZK_(G)) ! The specific volume of each layer [R-1 ~> m3 kg-1]. real :: dalpha_int(SZK_(G)+1) ! The change in specific volume across each ! interface [R-1 ~> m3 kg-1]. - integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz, nkmb + integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz, nkmb, start, npts 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 + start = Isq - (G%isd-1) ; npts = G%iec - Isq + 2 use_p_atm = .false. if (present(p_atm)) then ; if (associated(p_atm)) use_p_atm = .true. ; endif @@ -227,8 +228,8 @@ subroutine PressureForce_Mont_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, pb 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(:), G%HI, & - tv%eqn_of_state, US, halo=1) + call calculate_density(tv%T(:,j,nkmb), tv%S(:,j,nkmb), p_ref, Rho_cv_BL(:), start, npts, & + tv%eqn_of_state, US=US) 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) @@ -244,8 +245,8 @@ subroutine PressureForce_Mont_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, pb endif !$OMP parallel do default(shared) private(rho_in_situ) do k=1,nz ; do j=Jsq,Jeq+1 - call calculate_density(tv_tmp%T(:,j,k), tv_tmp%S(:,j,k), p_ref, rho_in_situ, G%HI, & - tv%eqn_of_state, US, halo=1) + call calculate_density(tv_tmp%T(:,j,k), tv_tmp%S(:,j,k), p_ref, rho_in_situ, start, npts, & + tv%eqn_of_state, US=US) do i=Isq,Ieq+1 ; alpha_star(i,j,k) = 1.0 / rho_in_situ(i) ; enddo enddo ; enddo endif ! use_EOS @@ -408,12 +409,13 @@ subroutine PressureForce_Mont_Bouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, pbce, ! gradient terms are to be split into ! barotropic and baroclinic pieces. type(thermo_var_ptrs) :: tv_tmp! A structure of temporary T & S. - integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz, nkmb + integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz, nkmb, start, npts 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 + start = Isq - (G%isd-1) ; npts = G%iec - Isq + 2 use_p_atm = .false. if (present(p_atm)) then ; if (associated(p_atm)) use_p_atm = .true. ; endif @@ -482,8 +484,8 @@ subroutine PressureForce_Mont_Bouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, pbce, 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(:), G%HI, & - tv%eqn_of_state, US, halo=1) + call calculate_density(tv%T(:,j,nkmb), tv%S(:,j,nkmb), p_ref, Rho_cv_BL(:), start, npts, & + tv%eqn_of_state, US=US) do k=nkmb+1,nz ; do i=Isq,Ieq+1 if (GV%Rlay(k) < Rho_cv_BL(i)) then @@ -503,8 +505,8 @@ subroutine PressureForce_Mont_Bouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, pbce, ! will come down with a fatal error if there is any compressibility. !$OMP parallel do default(shared) do k=1,nz+1 ; do j=Jsq,Jeq+1 - call calculate_density(tv_tmp%T(:,j,k), tv_tmp%S(:,j,k), p_ref, rho_star(:,j,k), G%HI, & - tv%eqn_of_state, US, halo=1) + call calculate_density(tv_tmp%T(:,j,k), tv_tmp%S(:,j,k), p_ref, rho_star(:,j,k), start, npts, & + tv%eqn_of_state, US=US) do i=Isq,Ieq+1 ; rho_star(i,j,k) = G_Rho0*rho_star(i,j,k) ; enddo enddo ; enddo endif ! use_EOS @@ -630,9 +632,10 @@ subroutine Set_pbce_Bouss(e, tv, G, GV, US, Rho0, GFS_scale, pbce, rho_star) ! an equation of state. real :: z_neglect ! A thickness that is so small it is usually lost ! in roundoff and can be neglected [Z ~> m]. - integer :: Isq, Ieq, Jsq, Jeq, nz, i, j, k + integer :: Isq, Ieq, Jsq, Jeq, nz, i, j, k, start, npts Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB ; nz = G%ke + start = Isq - (G%isd-1) ; npts = G%iec - Isq + 2 Rho0xG = Rho0 * GV%g_Earth G_Rho0 = GV%g_Earth / GV%Rho0 @@ -659,8 +662,8 @@ subroutine Set_pbce_Bouss(e, tv, G, GV, US, Rho0, GFS_scale, pbce, rho_star) Ihtot(i) = GV%H_to_Z / ((e(i,j,1)-e(i,j,nz+1)) + z_neglect) press(i) = -Rho0xG*e(i,j,1) enddo - call calculate_density(tv%T(:,j,1), tv%S(:,j,1), press, rho_in_situ, G%HI, & - tv%eqn_of_state, US, halo=1) + call calculate_density(tv%T(:,j,1), tv%S(:,j,1), press, rho_in_situ, start, npts, & + tv%eqn_of_state, US=US) do i=Isq,Ieq+1 pbce(i,j,1) = G_Rho0*(GFS_scale * rho_in_situ(i)) * GV%H_to_Z enddo @@ -670,8 +673,8 @@ subroutine Set_pbce_Bouss(e, tv, G, GV, US, Rho0, GFS_scale, pbce, rho_star) T_int(i) = 0.5*(tv%T(i,j,k-1)+tv%T(i,j,k)) S_int(i) = 0.5*(tv%S(i,j,k-1)+tv%S(i,j,k)) enddo - call calculate_density_derivs(T_int, S_int, press, dR_dT, dR_dS, G%HI, & - tv%eqn_of_state, US, halo=1) + call calculate_density_derivs(T_int, S_int, press, dR_dT, dR_dS, start, npts, & + tv%eqn_of_state, US=US) do i=Isq,Ieq+1 pbce(i,j,k) = pbce(i,j,k-1) + G_Rho0 * & ((e(i,j,K) - e(i,j,nz+1)) * Ihtot(i)) * & @@ -730,9 +733,10 @@ subroutine Set_pbce_nonBouss(p, tv, G, GV, US, GFS_scale, pbce, alpha_star) real :: dp_neglect ! A thickness that is so small it is usually lost ! in roundoff and can be neglected [R L2 T-2 ~> Pa]. logical :: use_EOS ! If true, density is calculated from T & S using an equation of state. - integer :: Isq, Ieq, Jsq, Jeq, nz, i, j, k + integer :: Isq, Ieq, Jsq, Jeq, nz, i, j, k, start, npts Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB ; nz = G%ke + start = Isq - (G%isd-1) ; npts = G%iec - Isq + 2 use_EOS = associated(tv%eqn_of_state) @@ -755,8 +759,8 @@ subroutine Set_pbce_nonBouss(p, tv, G, GV, US, GFS_scale, pbce, alpha_star) else !$OMP parallel do default(shared) private(T_int,S_int,dR_dT,dR_dS,rho_in_situ) do j=Jsq,Jeq+1 - call calculate_density(tv%T(:,j,nz), tv%S(:,j,nz), p(:,j,nz+1), rho_in_situ, G%HI, & - tv%eqn_of_state, US, halo=1) + call calculate_density(tv%T(:,j,nz), tv%S(:,j,nz), p(:,j,nz+1), rho_in_situ, start, npts, & + tv%eqn_of_state, US=US) do i=Isq,Ieq+1 C_htot(i,j) = dP_dH / ((p(i,j,nz+1)-p(i,j,1)) + dp_neglect) pbce(i,j,nz) = dP_dH / (rho_in_situ(i)) @@ -766,9 +770,9 @@ subroutine Set_pbce_nonBouss(p, tv, G, GV, US, GFS_scale, pbce, alpha_star) T_int(i) = 0.5*(tv%T(i,j,k)+tv%T(i,j,k+1)) S_int(i) = 0.5*(tv%S(i,j,k)+tv%S(i,j,k+1)) enddo - call calculate_density(T_int, S_int, p(:,j,k+1), rho_in_situ, G%HI, tv%eqn_of_state, US, halo=1) - call calculate_density_derivs(T_int, S_int, p(:,j,k+1), dR_dT, dR_dS, G%HI, & - tv%eqn_of_state, US, halo=1) + call calculate_density(T_int, S_int, p(:,j,k+1), rho_in_situ, start, npts, tv%eqn_of_state, US=US) + call calculate_density_derivs(T_int, S_int, p(:,j,k+1), dR_dT, dR_dS, start, npts, & + tv%eqn_of_state, US=US) do i=Isq,Ieq+1 pbce(i,j,k) = pbce(i,j,k+1) + ((p(i,j,K+1)-p(i,j,1))*C_htot(i,j)) * & ((dR_dT(i)*(tv%T(i,j,k+1)-tv%T(i,j,k)) + & diff --git a/src/core/MOM_PressureForce_analytic_FV.F90 b/src/core/MOM_PressureForce_analytic_FV.F90 index 4f85980f00..f0a4485399 100644 --- a/src/core/MOM_PressureForce_analytic_FV.F90 +++ b/src/core/MOM_PressureForce_analytic_FV.F90 @@ -176,12 +176,13 @@ subroutine PressureForce_AFV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p real :: H_to_RL2_T2 ! A factor to convert from thicknesss units (H) to pressure units [R L2 T-2 H-1 ~> Pa H-1]. ! real :: oneatm = 101325.0 ! 1 atm in [Pa] = [kg m-1 s-2] real, parameter :: C1_6 = 1.0/6.0 - integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz, nkmb + integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz, nkmb, start, npts 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 + start = Isq - (G%isd-1) ; npts = G%iec - Isq + 2 if (.not.associated(CS)) call MOM_error(FATAL, & "MOM_PressureForce_AFV_nonBouss: Module must be initialized before it is used.") @@ -227,8 +228,8 @@ subroutine PressureForce_AFV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p 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(:), G%HI, & - tv%eqn_of_state, US, halo=1) + call calculate_density(tv%T(:,j,nkmb), tv%S(:,j,nkmb), p_ref, Rho_cv_BL(:), start, npts, & + tv%eqn_of_state, US=US) 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) @@ -333,8 +334,8 @@ subroutine PressureForce_AFV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p 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, G%HI, & - tv%eqn_of_state, US, halo=1) + call calculate_density(tv_tmp%T(:,j,1), tv_tmp%S(:,j,1), p(:,j,1), rho_in_situ, start, npts, & + tv%eqn_of_state, US=US) 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)) @@ -503,12 +504,13 @@ subroutine PressureForce_AFV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_at 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, ie, js, je, Isq, Ieq, Jsq, Jeq, nz, nkmb, start, npts 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 + start = Isq - (G%isd-1) ; npts = G%iec - Isq + 2 if (.not.associated(CS)) call MOM_error(FATAL, & "MOM_PressureForce_AFV_Bouss: Module must be initialized before it is used.") @@ -576,8 +578,8 @@ subroutine PressureForce_AFV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_at 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(:), G%HI, & - tv%eqn_of_state, US, halo=1) + call calculate_density(tv%T(:,j,nkmb), tv%S(:,j,nkmb), p_ref, Rho_cv_BL(:), start, npts, & + tv%eqn_of_state, US=US) do k=nkmb+1,nz ; do i=Isq,Ieq+1 if (GV%Rlay(k) < Rho_cv_BL(i)) then @@ -599,11 +601,11 @@ subroutine PressureForce_AFV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_at !$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, G%HI, & - tv%eqn_of_state, US, halo=1) + call calculate_density(tv_tmp%T(:,j,1), tv_tmp%S(:,j,1), p_atm(:,j), rho_in_situ, start, npts, & + tv%eqn_of_state, US=US) else - call calculate_density(tv_tmp%T(:,j,1), tv_tmp%S(:,j,1), p0, rho_in_situ, G%HI, & - tv%eqn_of_state, US, halo=1) + call calculate_density(tv_tmp%T(:,j,1), tv_tmp%S(:,j,1), p0, rho_in_situ, start, npts, & + tv%eqn_of_state, US=US) endif do i=Isq,Ieq+1 dM(i,j) = (CS%GFS_scale - 1.0) * (G_Rho0 * rho_in_situ(i)) * e(i,j,1) diff --git a/src/core/MOM_PressureForce_blocked_AFV.F90 b/src/core/MOM_PressureForce_blocked_AFV.F90 index e949f6d69c..5ac7831479 100644 --- a/src/core/MOM_PressureForce_blocked_AFV.F90 +++ b/src/core/MOM_PressureForce_blocked_AFV.F90 @@ -173,13 +173,14 @@ subroutine PressureForce_blk_AFV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, real :: H_to_RL2_T2 ! A factor to convert from thicknesss units (H) to pressure units [R L2 T-2 H-1 ~> Pa H-1]. ! real :: oneatm = 101325.0 ! 1 atm in [Pa] = [kg m-1 s-2] real, parameter :: C1_6 = 1.0/6.0 - integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz, nkmb + integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz, nkmb, start, npts 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 + start = Isq - (G%isd-1) ; npts = G%iec - Isq + 2 if (.not.associated(CS)) call MOM_error(FATAL, & "MOM_PressureForce_AFV_nonBouss: Module must be initialized before it is used.") @@ -223,8 +224,8 @@ subroutine PressureForce_blk_AFV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, 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(:), G%HI, & - tv%eqn_of_state, US, halo=1) + call calculate_density(tv%T(:,j,nkmb), tv%S(:,j,nkmb), p_ref, Rho_cv_BL(:), start, npts, & + tv%eqn_of_state, US=US) 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) @@ -301,8 +302,8 @@ subroutine PressureForce_blk_AFV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, 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, G%HI, & - tv%eqn_of_state, US, halo=1) + call calculate_density(tv_tmp%T(:,j,1), tv_tmp%S(:,j,1), p(:,j,1), rho_in_situ, start, npts, & + tv%eqn_of_state, US=US) 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)) @@ -488,7 +489,7 @@ subroutine PressureForce_blk_AFV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, 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, ie, js, je, Isq, Ieq, Jsq, Jeq, nz, nkmb, start, npts 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 @@ -496,6 +497,7 @@ subroutine PressureForce_blk_AFV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, 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 + start = Isq - (G%isd-1) ; npts = G%iec - Isq + 2 if (.not.associated(CS)) call MOM_error(FATAL, & "MOM_PressureForce_AFV_Bouss: Module must be initialized before it is used.") @@ -563,8 +565,8 @@ subroutine PressureForce_blk_AFV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, 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(:), G%HI, & - tv%eqn_of_state, US, halo=1) + call calculate_density(tv%T(:,j,nkmb), tv%S(:,j,nkmb), p_ref, Rho_cv_BL(:), start, npts, & + tv%eqn_of_state, US=US) do k=nkmb+1,nz ; do i=Isq,Ieq+1 if (GV%Rlay(k) < Rho_cv_BL(i)) then @@ -586,11 +588,11 @@ subroutine PressureForce_blk_AFV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, !$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, G%HI, & - tv%eqn_of_state, US, halo=1) + call calculate_density(tv_tmp%T(:,j,1), tv_tmp%S(:,j,1), p_atm(:,j), rho_in_situ, start, npts, & + tv%eqn_of_state, US=US) else - call calculate_density(tv_tmp%T(:,j,1), tv_tmp%S(:,j,1), p0, rho_in_situ, G%HI, & - tv%eqn_of_state, US, halo=1) + call calculate_density(tv_tmp%T(:,j,1), tv_tmp%S(:,j,1), p0, rho_in_situ, start, npts, & + tv%eqn_of_state, US=US) endif do i=Isq,Ieq+1 dM(i,j) = (CS%GFS_scale - 1.0) * (G_Rho0 * rho_in_situ(i)) * e(i,j,1) diff --git a/src/parameterizations/vertical/MOM_set_viscosity.F90 b/src/parameterizations/vertical/MOM_set_viscosity.F90 index f7ae639fa0..fd5e0e7ab8 100644 --- a/src/parameterizations/vertical/MOM_set_viscosity.F90 +++ b/src/parameterizations/vertical/MOM_set_viscosity.F90 @@ -273,12 +273,13 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, symmetrize) ! accuracy of a single L(:) Newton iteration logical :: use_L0, do_one_L_iter ! Control flags for L(:) Newton iteration logical :: use_BBL_EOS, do_i(SZIB_(G)) - integer :: i, j, k, is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz, m, n, K2, nkmb, nkml + integer :: i, j, k, is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz, m, n, K2, nkmb, nkml, start, npts integer :: itt, maxitt=20 type(ocean_OBC_type), pointer :: OBC => NULL() 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 + start = Isq - (G%isd-1) ; npts = G%iec - Isq + 2 nkmb = GV%nk_rho_varies ; nkml = GV%nkml h_neglect = GV%H_subroundoff Rho0x400_G = 400.0*(GV%Rho0 / (US%L_to_Z**2 * GV%g_Earth)) * GV%Z_to_H @@ -315,8 +316,8 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, symmetrize) do i=Isq,Ieq+1 ; p_ref(i) = tv%P_Ref ; enddo !$OMP parallel do default(shared) do k=1,nkmb ; do j=Jsq,Jeq+1 - call calculate_density(tv%T(:,j,k), tv%S(:,j,k), p_ref, Rml(:,j,k), G%HI, & - tv%eqn_of_state, US, halo=1) + call calculate_density(tv%T(:,j,k), tv%S(:,j,k), p_ref, Rml(:,j,k), start, npts, & + tv%eqn_of_state, US=US) enddo ; enddo endif From a00c3277f5aa0ddcc67fdcc61f9ad588d7ee4dc7 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 15 Apr 2020 06:27:39 -0400 Subject: [PATCH 191/316] (*)Reordered setting calculate_density loop bounds Moved the line setting the calculate_density loop bounds for viscosity to come after another line that changes the velocity point bounds, fixing a bug with non-symmetric memory that was introduced in the previous commit and that is being detected by the automated testing. All answers are once again bitwise identical in the MOM6-examples test suite. --- src/parameterizations/vertical/MOM_set_viscosity.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/parameterizations/vertical/MOM_set_viscosity.F90 b/src/parameterizations/vertical/MOM_set_viscosity.F90 index fd5e0e7ab8..4f08d37fbc 100644 --- a/src/parameterizations/vertical/MOM_set_viscosity.F90 +++ b/src/parameterizations/vertical/MOM_set_viscosity.F90 @@ -279,7 +279,6 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, symmetrize) 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 - start = Isq - (G%isd-1) ; npts = G%iec - Isq + 2 nkmb = GV%nk_rho_varies ; nkml = GV%nkml h_neglect = GV%H_subroundoff Rho0x400_G = 400.0*(GV%Rho0 / (US%L_to_Z**2 * GV%g_Earth)) * GV%Z_to_H @@ -293,6 +292,7 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, symmetrize) if (present(symmetrize)) then ; if (symmetrize) then Jsq = js-1 ; Isq = is-1 endif ; endif + start = Isq - (G%isd-1) ; npts = G%iec - Isq + 2 if (CS%debug) then call uvchksum("Start set_viscous_BBL [uv]", u, v, G%HI, haloshift=1, scale=US%L_T_to_m_s) From 3dd70fe71930faaff5f8818ef3f9256335393ef4 Mon Sep 17 00:00:00 2001 From: alperaltuntas Date: Wed, 15 Apr 2020 11:56:23 -0600 Subject: [PATCH 192/316] remove unnecessary kOBL computation --- .../vertical/MOM_CVMix_KPP.F90 | 25 ------------------- 1 file changed, 25 deletions(-) diff --git a/src/parameterizations/vertical/MOM_CVMix_KPP.F90 b/src/parameterizations/vertical/MOM_CVMix_KPP.F90 index 8c9c2b0e06..6056dd3eab 100644 --- a/src/parameterizations/vertical/MOM_CVMix_KPP.F90 +++ b/src/parameterizations/vertical/MOM_CVMix_KPP.F90 @@ -1415,31 +1415,6 @@ subroutine KPP_smooth_BLD(CS,G,GV,h) enddo ! s-loop - ! Update kOBL for smoothed OBL depths - do j = G%jsc, G%jec - do i = G%isc, G%iec - - ! skip land points - if (G%mask2dT(i,j)==0.) cycle - - 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 - - CS%kOBL(i,j) = CVMix_kpp_compute_kOBL_depth( iFaceHeight, cellHeight, CS%OBLdepth(i,j) ) - - enddo - enddo - end subroutine KPP_smooth_BLD From f632ffc87422c5016aa3297776eab30bcdc8d8bf Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Wed, 15 Apr 2020 14:34:52 -0400 Subject: [PATCH 193/316] Explicit array rotation index; modulo chksum turns Array index assignment in rotation is now explicit (i.e. A(:,:)). Modulo operators are applied to the turns in the rotated mpp checksums, in order to prevent redundant allocations of identical arrays. Explicit deallocation of the rotated checksum has also been added. An error in the comments of external forcing diagnostics was also amended. Thanks to Robert Hallberg for these suggestions. --- src/core/MOM_forcing_type.F90 | 8 ++--- src/framework/MOM_array_transform.F90 | 44 +++++++++++++-------------- src/framework/MOM_transform_FMS.F90 | 22 +++++++++----- 3 files changed, 40 insertions(+), 34 deletions(-) diff --git a/src/core/MOM_forcing_type.F90 b/src/core/MOM_forcing_type.F90 index 0a624b93e6..2f3d0d1b5f 100644 --- a/src/core/MOM_forcing_type.F90 +++ b/src/core/MOM_forcing_type.F90 @@ -2232,8 +2232,8 @@ subroutine mech_forcing_diags(forces_in, dt, G, time_end, diag, handles) call cpu_clock_begin(handles%id_clock_forcing) - ! NOTE: post_data expects data to be on the input index map, so any rotations - ! must be undone before saving the output. + ! NOTE: post_data expects data to be on the rotated index map, so any + ! rotations must be applied before saving the output. turns = diag%G%HI%turns if (turns /= 0) then allocate(forces) @@ -2299,8 +2299,8 @@ subroutine forcing_diagnostics(fluxes_in, sfc_state, G_in, US, time_end, diag, h call cpu_clock_begin(handles%id_clock_forcing) - ! NOTE: post_data expects data to be on the input index map, so any rotations - ! must be undone before saving the output. + ! NOTE: post_data expects data to be on the rotated index map, so any + ! rotations must be applied before saving the output. turns = diag%G%HI%turns if (turns /= 0) then G => diag%G diff --git a/src/framework/MOM_array_transform.F90 b/src/framework/MOM_array_transform.F90 index 09d55ad50b..179bd6550e 100644 --- a/src/framework/MOM_array_transform.F90 +++ b/src/framework/MOM_array_transform.F90 @@ -83,14 +83,14 @@ subroutine rotate_array_real_2d(A_in, turns, A) select case (modulo(turns, 4)) case(0) - A = A_in + A(:,:) = A_in(:,:) case(1) - A = transpose(A_in) - A = A(n:1:-1, :) + A(:,:) = transpose(A_in) + A(:,:) = A(n:1:-1, :) case(2) - A = A_in(m:1:-1, n:1:-1) + A(:,:) = A_in(m:1:-1, n:1:-1) case(3) - A = transpose(A_in(m:1:-1, :)) + A(:,:) = transpose(A_in(m:1:-1, :)) end select end subroutine rotate_array_real_2d @@ -103,7 +103,7 @@ subroutine rotate_array_real_3d(A_in, turns, A) integer :: k - do k = lbound(A_in, 3), ubound(A_in, 3) + do k = 1, size(A_in, 3) call rotate_array(A_in(:,:,k), turns, A(:,:,k)) enddo end subroutine rotate_array_real_3d @@ -117,7 +117,7 @@ subroutine rotate_array_real_4d(A_in, turns, A) integer :: n - do n = lbound(A_in, 4), ubound(A_in, 4) + do n = 1, size(A_in, 4) call rotate_array(A_in(:,:,:,n), turns, A(:,:,:,n)) enddo end subroutine rotate_array_real_4d @@ -136,14 +136,14 @@ subroutine rotate_array_integer(A_in, turns, A) select case (modulo(turns, 4)) case(0) - A = A_in + A(:,:) = A_in(:,:) case(1) - A = transpose(A_in) - A = A(n:1:-1, :) + A(:,:) = transpose(A_in) + A(:,:) = A(n:1:-1, :) case(2) - A = A_in(m:1:-1, n:1:-1) + A(:,:) = A_in(m:1:-1, n:1:-1) case(3) - A = transpose(A_in(m:1:-1, :)) + A(:,:) = transpose(A_in(m:1:-1, :)) end select end subroutine rotate_array_integer @@ -161,14 +161,14 @@ subroutine rotate_array_logical(A_in, turns, A) select case (modulo(turns, 4)) case(0) - A = A_in + A(:,:) = A_in(:,:) case(1) - A = transpose(A_in) - A = A(n:1:-1, :) + A(:,:) = transpose(A_in) + A(:,:) = A(n:1:-1, :) case(2) - A = A_in(m:1:-1, n:1:-1) + A(:,:) = A_in(m:1:-1, n:1:-1) case(3) - A = transpose(A_in(m:1:-1, :)) + A(:,:) = transpose(A_in(m:1:-1, :)) end select end subroutine rotate_array_logical @@ -201,7 +201,7 @@ subroutine rotate_array_pair_real_3d(A_in, B_in, turns, A, B) integer :: k - do k = lbound(A_in, 3), ubound(A_in, 3) + do k = 1, size(A_in, 3) call rotate_array_pair(A_in(:,:,k), B_in(:,:,k), turns, & A(:,:,k), B(:,:,k)) enddo @@ -237,10 +237,10 @@ subroutine rotate_vector_real_2d(A_in, B_in, turns, A, B) call rotate_array_pair(A_in, B_in, turns, A, B) if (modulo(turns, 4) == 1 .or. modulo(turns, 4) == 2) & - A = -A + A(:,:) = -A(:,:) if (modulo(turns, 4) == 2 .or. modulo(turns, 4) == 3) & - B = -B + B(:,:) = -B(:,:) end subroutine rotate_vector_real_2d @@ -254,7 +254,7 @@ subroutine rotate_vector_real_3d(A_in, B_in, turns, A, B) integer :: k - do k = lbound(A_in, 3), ubound(A_in, 3) + do k = 1, size(A_in, 3) call rotate_vector(A_in(:,:,k), B_in(:,:,k), turns, A(:,:,k), B(:,:,k)) enddo end subroutine rotate_vector_real_3d @@ -270,7 +270,7 @@ subroutine rotate_vector_real_4d(A_in, B_in, turns, A, B) integer :: n - do n = lbound(A_in, 4), ubound(A_in, 4) + do n = 1, size(A_in, 4) call rotate_vector(A_in(:,:,:,n), B_in(:,:,:,n), turns, & A(:,:,:,n), B(:,:,:,n)) enddo diff --git a/src/framework/MOM_transform_FMS.F90 b/src/framework/MOM_transform_FMS.F90 index 2af6088c90..97e0be85f6 100644 --- a/src/framework/MOM_transform_FMS.F90 +++ b/src/framework/MOM_transform_FMS.F90 @@ -99,7 +99,7 @@ function rotated_mpp_chksum_real_2d(field, pelist, mask_val, turns) & qturns = 0 if (present(turns)) & - qturns = turns + qturns = modulo(turns, 4) if (qturns == 0) then chksum = mpp_chksum(field, pelist=pelist, mask_val=mask_val) @@ -126,7 +126,7 @@ function rotated_mpp_chksum_real_3d(field, pelist, mask_val, turns) & qturns = 0 if (present(turns)) & - qturns = turns + qturns = modulo(turns, 4) if (qturns == 0) then chksum = mpp_chksum(field, pelist=pelist, mask_val=mask_val) @@ -153,7 +153,7 @@ function rotated_mpp_chksum_real_4d(field, pelist, mask_val, turns) & qturns = 0 if (present(turns)) & - qturns = turns + qturns = modulo(turns, 4) if (qturns == 0) then chksum = mpp_chksum(field, pelist=pelist, mask_val=mask_val) @@ -220,7 +220,7 @@ subroutine rotated_write_field_real_2d(io_unit, field_md, domain, field, & qturns = 0 if (present(turns)) & - qturns = turns + qturns = modulo(turns, 4) if (qturns == 0) then call write_field(io_unit, field_md, domain, field, tstamp=tstamp, & @@ -252,7 +252,7 @@ subroutine rotated_write_field_real_3d(io_unit, field_md, domain, field, & qturns = 0 if (present(turns)) & - qturns = turns + qturns = modulo(turns, 4) if (qturns == 0) then call write_field(io_unit, field_md, domain, field, tstamp=tstamp, & @@ -283,7 +283,8 @@ subroutine rotated_write_field_real_4d(io_unit, field_md, domain, field, & integer :: qturns qturns = 0 - if (present(turns)) qturns = turns + if (present(turns)) & + qturns = modulo(turns, 4) if (qturns == 0) then call write_field(io_unit, field_md, domain, field, tstamp=tstamp, & @@ -338,7 +339,9 @@ subroutine rotated_time_interp_external_2d(fms_id, time, data_in, interp, & call MOM_error(FATAL, "Rotation of masked output not yet support") qturns = 0 - if (present(turns)) qturns = turns + if (present(turns)) & + qturns = modulo(turns, 4) + if (qturns == 0) then call time_interp_external(fms_id, time, data_in, interp=interp, & @@ -352,6 +355,7 @@ subroutine rotated_time_interp_external_2d(fms_id, time, data_in, interp, & is_in=is_in, ie_in=ie_in, js_in=js_in, je_in=je_in, & window_id=window_id) call rotate_array(data_pre, turns, data_in) + deallocate(data_pre) endif end subroutine rotated_time_interp_external_2d @@ -379,7 +383,8 @@ subroutine rotated_time_interp_external_3d(fms_id, time, data_in, interp, & call MOM_error(FATAL, "Rotation of masked output not yet support") qturns = 0 - if (present(turns)) qturns = turns + if (present(turns)) & + qturns = modulo(turns, 4) if (qturns == 0) then call time_interp_external(fms_id, time, data_in, interp=interp, & @@ -393,6 +398,7 @@ subroutine rotated_time_interp_external_3d(fms_id, time, data_in, interp, & is_in=is_in, ie_in=ie_in, js_in=js_in, je_in=je_in, & window_id=window_id) call rotate_array(data_pre, turns, data_in) + deallocate(data_pre) endif end subroutine rotated_time_interp_external_3d From 6cf28bf15f06ce9f7015b2db1fc51d63438f4501 Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Wed, 15 Apr 2020 15:06:55 -0600 Subject: [PATCH 194/316] Add option to scale AH via a biharmonic Reynolds # This is done via parameter RE_AH: if nonzero, the biharmonic coefficient is scaled so that the biharmonic Reynolds number is equal to this. --- .../lateral/MOM_hor_visc.F90 | 137 ++++-------------- 1 file changed, 30 insertions(+), 107 deletions(-) diff --git a/src/parameterizations/lateral/MOM_hor_visc.F90 b/src/parameterizations/lateral/MOM_hor_visc.F90 index c3ec878bc1..f3c593819a 100644 --- a/src/parameterizations/lateral/MOM_hor_visc.F90 +++ b/src/parameterizations/lateral/MOM_hor_visc.F90 @@ -46,6 +46,8 @@ module MOM_hor_visc !! limited to guarantee stability. logical :: better_bound_Ah !< If true, use a more careful bounding of the !! biharmonic viscosity to guarantee stability. + real :: Re_Ah !! If nonzero, the biharmonic coefficient is scaled + !< so that the biharmonic Reynolds number is equal to this. real :: bound_coef !< The nondimensional coefficient of the ratio of !! the viscosity bounds to the theoretical maximum !! for stability without considering other terms [nondim]. @@ -163,14 +165,16 @@ module MOM_hor_visc Biharm5_const_xx, & !< Biharmonic metric-dependent constants [L5 ~> m5] Laplac3_const_xx, & !< Laplacian metric-dependent constants [L3 ~> m3] Biharm_const_xx, & !< Biharmonic metric-dependent constants [L4 ~> m4] - Biharm_const2_xx !< Biharmonic metric-dependent constants [T L4 ~> s m4] + Biharm_const2_xx, & !< Biharmonic metric-dependent constants [T L4 ~> s m4] + Re_Ah_const_xx !< Biharmonic metric-dependent constants [L3 ~> m3] real ALLOCABLE_, dimension(NIMEMB_PTR_,NJMEMB_PTR_) :: & Laplac2_const_xy, & !< Laplacian metric-dependent constants [L2 ~> m2] Biharm5_const_xy, & !< Biharmonic metric-dependent constants [L5 ~> m5] Laplac3_const_xy, & !< Laplacian metric-dependent constants [L3 ~> m3] Biharm_const_xy, & !< Biharmonic metric-dependent constants [L4 ~> m4] - Biharm_const2_xy !< Biharmonic metric-dependent constants [T L4 ~> s m4] + Biharm_const2_xy, & !< Biharmonic metric-dependent constants [T L4 ~> s m4] + Re_Ah_const_xy !< Biharmonic metric-dependent constants [L3 ~> m3] type(diag_ctrl), pointer :: diag => NULL() !< structure to regulate diagnostics @@ -339,6 +343,7 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, real :: backscat_subround ! The ratio of f over Shear_mag that is so small that the backscatter ! calculation gives the same value as if f were 0 [nondim]. real :: H0_GME ! Depth used to scale down GME coefficient in shallow areas [Z ~> m] + real :: KE ! Local kinetic energy [L2 T-2 ~> m2 s-2] logical :: rescale_Kh, legacy_bound logical :: find_FrictWork logical :: apply_OBC = .false. @@ -874,6 +879,11 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, if (use_MEKE_Au) Ah = Ah + MEKE%Au(i,j) ! *Add* the MEKE contribution + if (CS%Re_Ah > 0.0) then + KE = 0.125*((u(I,j,k)+u(I-1,j,k))**2 + (v(i,J,k)+v(i,J-1,k))**2) + Ah = sqrt(KE) * CS%Re_Ah_const_xx(i,j) + endif + if (CS%better_bound_Ah) then Ah = MIN(Ah, visc_bound_rem*hrat_min*CS%Ah_Max_xx(i,j)) endif @@ -1047,6 +1057,11 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, (MEKE%Au(I+1,J) + MEKE%Au(I,J+1)) ) endif + if (CS%Re_Ah > 0.0) then + KE = 0.125*((u(I,j,k)+u(I,j+1,k))**2 + (v(i,J,k)+v(i+1,J,k))**2) + Ah = sqrt(KE) * CS%Re_Ah_const_xy(i,j) + endif + if (CS%better_bound_Ah) then Ah = MIN(Ah, visc_bound_rem*hrat_min*CS%Ah_Max_xy(I,J)) endif @@ -1363,7 +1378,6 @@ subroutine hor_visc_init(Time, G, US, param_file, diag, CS, MEKE) logical :: split ! If true, use the split time stepping scheme. ! If false and USE_GME = True, issue a FATAL error. logical :: default_2018_answers - character(len=64) :: inputdir, filename real :: deg2rad ! Converts degrees to radians real :: slat_fn ! sin(lat)**Kh_pwr_of_sine @@ -1372,28 +1386,22 @@ subroutine hor_visc_init(Time, G, US, param_file, diag, CS, MEKE) integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB integer :: i, j - ! This include declares and sets the variable "version". #include "version_variable.h" character(len=40) :: mdl = "MOM_hor_visc" ! module name - 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 IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB - if (associated(CS)) then call MOM_error(WARNING, "hor_visc_init called with an associated "// & "control structure.") return endif allocate(CS) - CS%diag => diag - ! Read parameters and write them to the model log. call log_version(param_file, mdl, version, "") - ! It is not clear whether these initialization lines are needed for the ! cases where the corresponding parameters are not read. CS%bound_Kh = .false. ; CS%better_bound_Kh = .false. ; CS%Smagorinsky_Kh = .false. ; CS%Leith_Kh = .false. @@ -1403,13 +1411,10 @@ subroutine hor_visc_init(Time, G, US, param_file, diag, CS, MEKE) CS%Modified_Leith = .false. CS%anisotropic = .false. CS%dynamic_aniso = .false. - Kh = 0.0 ; Ah = 0.0 - ! If GET_ALL_PARAMS is true, all parameters are read in all cases to enable ! parameter spelling checks. call get_param(param_file, mdl, "GET_ALL_PARAMS", get_all, default=.false.) - call get_param(param_file, mdl, "DEFAULT_2018_ANSWERS", default_2018_answers, & "This sets the default value for the various _2018_ANSWERS parameters.", & default=.true.) @@ -1417,9 +1422,7 @@ subroutine hor_visc_init(Time, G, US, param_file, diag, CS, MEKE) "If true, use the order of arithmetic and expressions that recover the "//& "answers from the end of 2018. Otherwise, use updated and more robust "//& "forms of the same expressions.", default=default_2018_answers) - call get_param(param_file, mdl, "DEBUG", CS%debug, default=.false.) - call get_param(param_file, mdl, "LAPLACIAN", CS%Laplacian, & "If true, use a Laplacian horizontal viscosity.", & default=.false.) @@ -1445,7 +1448,6 @@ subroutine hor_visc_init(Time, G, US, param_file, diag, CS, MEKE) "The power used to raise SIN(LAT) when using a latitudinally "//& "dependent background viscosity.", & units = "nondim", default=4.0) - call get_param(param_file, mdl, "SMAGORINSKY_KH", CS%Smagorinsky_Kh, & "If true, use a Smagorinsky nonlinear eddy viscosity.", & default=.false.) @@ -1454,11 +1456,9 @@ subroutine hor_visc_init(Time, G, US, param_file, diag, CS, MEKE) "The nondimensional Laplacian Smagorinsky constant, "//& "often 0.15.", units="nondim", default=0.0, & fail_if_missing = CS%Smagorinsky_Kh) - call get_param(param_file, mdl, "LEITH_KH", CS%Leith_Kh, & "If true, use a Leith nonlinear eddy viscosity.", & default=.false.) - call get_param(param_file, mdl, "MODIFIED_LEITH", CS%Modified_Leith, & "If true, add a term to Leith viscosity which is "//& "proportional to the gradient of divergence.", & @@ -1466,7 +1466,6 @@ subroutine hor_visc_init(Time, G, US, param_file, diag, CS, MEKE) call get_param(param_file, mdl, "RES_SCALE_MEKE_VISC", CS%res_scale_MEKE, & "If true, the viscosity contribution from MEKE is scaled by "//& "the resolution function.", default=.false.) - if (CS%Leith_Kh .or. get_all) then call get_param(param_file, mdl, "LEITH_LAP_CONST", Leith_Lap_const, & "The nondimensional Laplacian Leith constant, "//& @@ -1525,7 +1524,6 @@ subroutine hor_visc_init(Time, G, US, param_file, diag, CS, MEKE) "to the spherical coordinates.", units = "nondim", fail_if_missing=.true.) end select endif - call get_param(param_file, mdl, "BIHARMONIC", CS%biharmonic, & "If true, use a biharmonic horizontal viscosity. "//& "BIHARMONIC may be used with LAPLACIAN.", & @@ -1552,7 +1550,6 @@ subroutine hor_visc_init(Time, G, US, param_file, diag, CS, MEKE) call get_param(param_file, mdl, "LEITH_AH", CS%Leith_Ah, & "If true, use a biharmonic Leith nonlinear eddy "//& "viscosity.", default=.false.) - call get_param(param_file, mdl, "BOUND_AH", CS%bound_Ah, & "If true, the biharmonic coefficient is locally limited "//& "to be stable.", default=.true.) @@ -1560,13 +1557,16 @@ subroutine hor_visc_init(Time, G, US, param_file, diag, CS, MEKE) "If true, the biharmonic coefficient is locally limited "//& "to be stable with a better bounding than just BOUND_AH.", & default=CS%bound_Ah) + call get_param(param_file, mdl, "RE_AH", CS%Re_Ah, & + "If nonzero, the biharmonic coefficient is scaled "//& + "so that the biharmonic Reynolds number is equal to this.", & + units="nondim", default=0.0) if (CS%Smagorinsky_Ah .or. get_all) then call get_param(param_file, mdl, "SMAG_BI_CONST",Smag_bi_const, & "The nondimensional biharmonic Smagorinsky constant, "//& "typically 0.015 - 0.06.", units="nondim", default=0.0, & fail_if_missing = CS%Smagorinsky_Ah) - call get_param(param_file, mdl, "BOUND_CORIOLIS", bound_Cor_def, default=.false.) call get_param(param_file, mdl, "BOUND_CORIOLIS_BIHARM", CS%bound_Coriolis, & "If true use a viscosity that increases with the square "//& @@ -1585,29 +1585,24 @@ subroutine hor_visc_init(Time, G, US, param_file, diag, CS, MEKE) units="m s-1", default=maxvel, scale=US%m_s_to_L_T) endif endif - if (CS%Leith_Ah .or. get_all) & call get_param(param_file, mdl, "LEITH_BI_CONST", Leith_bi_const, & "The nondimensional biharmonic Leith constant, "//& "typical values are thus far undetermined.", units="nondim", default=0.0, & fail_if_missing = CS%Leith_Ah) - endif - call get_param(param_file, mdl, "USE_LAND_MASK_FOR_HVISC", CS%use_land_mask, & "If true, use Use the land mask for the computation of thicknesses "//& "at velocity locations. This eliminates the dependence on arbitrary "//& "values over land or outside of the domain. Default is False in order to "//& "maintain answers with legacy experiments but should be changed to True "//& "for new experiments.", default=.false.) - if (CS%better_bound_Ah .or. CS%better_bound_Kh .or. get_all) & call get_param(param_file, mdl, "HORVISC_BOUND_COEF", CS%bound_coef, & "The nondimensional coefficient of the ratio of the "//& "viscosity bounds to the theoretical maximum for "//& "stability without considering other terms.", units="nondim", & default=0.8) - call get_param(param_file, mdl, "NOSLIP", CS%no_slip, & "If true, no slip boundary conditions are used; otherwise "//& "free slip boundary conditions are assumed. The "//& @@ -1615,47 +1610,37 @@ subroutine hor_visc_init(Time, G, US, param_file, diag, CS, MEKE) "cleaner than the no slip BCs. The use of free slip BCs "//& "is strongly encouraged, and no slip BCs are not used with "//& "the biharmonic viscosity.", default=.false.) - call get_param(param_file, mdl, "USE_KH_BG_2D", CS%use_Kh_bg_2d, & "If true, read a file containing 2-d background harmonic "//& "viscosities. The final viscosity is the maximum of the other "//& "terms and this background value.", default=.false.) - call get_param(param_file, mdl, "USE_GME", CS%use_GME, & "If true, use the GM+E backscatter scheme in association \n"//& "with the Gent and McWilliams parameterization.", default=.false.) - if (CS%use_GME) then call get_param(param_file, mdl, "SPLIT", split, & "Use the split time stepping if true.", default=.true., & do_not_log=.true.) if (.not. split) call MOM_error(FATAL,"ERROR: Currently, USE_GME = True "// & "cannot be used with SPLIT=False.") - call get_param(param_file, mdl, "GME_H0", CS%GME_h0, & "The strength of GME tapers quadratically to zero when the bathymetric "//& "depth is shallower than GME_H0.", units="m", scale=US%m_to_Z, & default=1000.0) - call get_param(param_file, mdl, "GME_EFFICIENCY", CS%GME_efficiency, & "The nondimensional prefactor multiplying the GME coefficient.", & units="nondim", default=1.0) - call get_param(param_file, mdl, "GME_LIMITER", CS%GME_limiter, & "The absolute maximum value the GME coefficient is allowed to take.", & units="m2 s-1", scale=US%m_to_L**2*US%T_to_s, default=1.0e7) - endif - if (CS%bound_Kh .or. CS%bound_Ah .or. CS%better_bound_Kh .or. CS%better_bound_Ah) & call get_param(param_file, mdl, "DT", dt, & "The (baroclinic) dynamics time step.", units="s", scale=US%s_to_T, & fail_if_missing=.true.) - if (CS%no_slip .and. CS%biharmonic) & call MOM_error(FATAL,"ERROR: NOSLIP and BIHARMONIC cannot be defined "// & "at the same time in MOM.") - if (.not.(CS%Laplacian .or. CS%biharmonic)) then ! Only issue inviscid warning if not in single column mode (usually 2x2 domain) if ( max(G%domain%niglobal, G%domain%njglobal)>2 ) call MOM_error(WARNING, & @@ -1663,9 +1648,7 @@ subroutine hor_visc_init(Time, G, US, param_file, diag, CS, MEKE) "LAPLACIAN or BIHARMONIC viscosity.") return ! We are not using either Laplacian or Bi-harmonic lateral viscosity endif - deg2rad = atan(1.0) / 45. - ALLOC_(CS%dx2h(isd:ied,jsd:jed)) ; CS%dx2h(:,:) = 0.0 ALLOC_(CS%dy2h(isd:ied,jsd:jed)) ; CS%dy2h(:,:) = 0.0 ALLOC_(CS%dx2q(IsdB:IedB,JsdB:JedB)) ; CS%dx2q(:,:) = 0.0 @@ -1674,7 +1657,6 @@ subroutine hor_visc_init(Time, G, US, param_file, diag, CS, MEKE) ALLOC_(CS%dy_dxT(isd:ied,jsd:jed)) ; CS%dy_dxT(:,:) = 0.0 ALLOC_(CS%dx_dyBu(IsdB:IedB,JsdB:JedB)) ; CS%dx_dyBu(:,:) = 0.0 ALLOC_(CS%dy_dxBu(IsdB:IedB,JsdB:JedB)) ; CS%dy_dxBu(:,:) = 0.0 - if (CS%Laplacian) then ALLOC_(CS%Kh_bg_xx(isd:ied,jsd:jed)) ; CS%Kh_bg_xx(:,:) = 0.0 ALLOC_(CS%Kh_bg_xy(IsdB:IedB,JsdB:JedB)) ; CS%Kh_bg_xy(:,:) = 0.0 @@ -1693,7 +1675,6 @@ subroutine hor_visc_init(Time, G, US, param_file, diag, CS, MEKE) endif ALLOC_(CS%reduction_xx(isd:ied,jsd:jed)) ; CS%reduction_xx(:,:) = 0.0 ALLOC_(CS%reduction_xy(IsdB:IedB,JsdB:JedB)) ; CS%reduction_xy(:,:) = 0.0 - if (CS%anisotropic) then ALLOC_(CS%n1n2_h(isd:ied,jsd:jed)) ; CS%n1n2_h(:,:) = 0.0 ALLOC_(CS%n1n1_m_n2n2_h(isd:ied,jsd:jed)) ; CS%n1n1_m_n2n2_h(:,:) = 0.0 @@ -1711,7 +1692,6 @@ subroutine hor_visc_init(Time, G, US, param_file, diag, CS, MEKE) "Runtime parameter ANISOTROPIC_MODE is out of range.") end select endif - if (CS%use_Kh_bg_2d) then ALLOC_(CS%Kh_bg_2d(isd:ied,jsd:jed)) ; CS%Kh_bg_2d(:,:) = 0.0 call get_param(param_file, mdl, "KH_BG_2D_FILENAME", filename, & @@ -1723,13 +1703,11 @@ subroutine hor_visc_init(Time, G, US, param_file, diag, CS, MEKE) G%domain, timelevel=1, scale=US%m_to_L**2*US%T_to_s) call pass_var(CS%Kh_bg_2d, G%domain) endif - if (CS%biharmonic) then ALLOC_(CS%Idx2dyCu(IsdB:IedB,jsd:jed)) ; CS%Idx2dyCu(:,:) = 0.0 ALLOC_(CS%Idx2dyCv(isd:ied,JsdB:JedB)) ; CS%Idx2dyCv(:,:) = 0.0 ALLOC_(CS%Idxdy2u(IsdB:IedB,jsd:jed)) ; CS%Idxdy2u(:,:) = 0.0 ALLOC_(CS%Idxdy2v(isd:ied,JsdB:JedB)) ; CS%Idxdy2v(:,:) = 0.0 - ALLOC_(CS%Ah_bg_xx(isd:ied,jsd:jed)) ; CS%Ah_bg_xx(:,:) = 0.0 ALLOC_(CS%Ah_bg_xy(IsdB:IedB,JsdB:JedB)) ; CS%Ah_bg_xy(:,:) = 0.0 if (CS%bound_Ah .or. CS%better_bound_Ah) then @@ -1748,8 +1726,11 @@ subroutine hor_visc_init(Time, G, US, param_file, diag, CS, MEKE) ALLOC_(CS%biharm5_const_xx(isd:ied,jsd:jed)) ; CS%biharm5_const_xx(:,:) = 0.0 ALLOC_(CS%biharm5_const_xy(IsdB:IedB,JsdB:JedB)) ; CS%biharm5_const_xy(:,:) = 0.0 endif + if (CS%Re_Ah > 0.0) then + ALLOC_(CS%Re_Ah_const_xx(isd:ied,jsd:jed)); CS%Re_Ah_const_xx(:,:) = 0.0 + ALLOC_(CS%Re_Ah_const_xy(IsdB:IedB,JsdB:JedB)); CS%Re_Ah_const_xy(:,:) = 0.0 + endif endif - do J=js-2,Jeq+1 ; do I=is-2,Ieq+1 CS%dx2q(I,J) = G%dxBu(I,J)*G%dxBu(I,J) ; CS%dy2q(I,J) = G%dyBu(I,J)*G%dyBu(I,J) CS%DX_dyBu(I,J) = G%dxBu(I,J)*G%IdyBu(I,J) ; CS%DY_dxBu(I,J) = G%dyBu(I,J)*G%IdxBu(I,J) @@ -1758,7 +1739,6 @@ subroutine hor_visc_init(Time, G, US, param_file, diag, CS, MEKE) CS%dx2h(i,j) = G%dxT(i,j)*G%dxT(i,j) ; CS%dy2h(i,j) = G%dyT(i,j)*G%dyT(i,j) CS%DX_dyT(i,j) = G%dxT(i,j)*G%IdyT(i,j) ; CS%DY_dxT(i,j) = G%dyT(i,j)*G%IdxT(i,j) enddo ; enddo - do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 CS%reduction_xx(i,j) = 1.0 if ((G%dy_Cu(I,j) > 0.0) .and. (G%dy_Cu(I,j) < G%dyCu(I,j)) .and. & @@ -1774,7 +1754,6 @@ subroutine hor_visc_init(Time, G, US, param_file, diag, CS, MEKE) (G%dx_Cv(i,J-1) < G%dxCv(i,J-1) * CS%reduction_xx(i,j))) & CS%reduction_xx(i,j) = G%dx_Cv(i,J-1) / (G%dxCv(i,J-1)) enddo ; enddo - do J=js-1,Jeq ; do I=is-1,Ieq CS%reduction_xy(I,J) = 1.0 if ((G%dy_Cu(I,j) > 0.0) .and. (G%dy_Cu(I,j) < G%dyCu(I,j)) .and. & @@ -1790,12 +1769,10 @@ subroutine hor_visc_init(Time, G, US, param_file, diag, CS, MEKE) (G%dx_Cv(i+1,J) < G%dxCv(i+1,J) * CS%reduction_xy(I,J))) & CS%reduction_xy(I,J) = G%dx_Cv(i+1,J) / (G%dxCv(i+1,J)) enddo ; enddo - if (CS%Laplacian) then ! The 0.3 below was 0.4 in MOM1.10. The change in hq requires ! this to be less than 1/3, rather than 1/2 as before. if (CS%bound_Kh .or. CS%bound_Ah) Kh_Limit = 0.3 / (dt*4.0) - ! Calculate and store the background viscosity at h-points do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 ! Static factors in the Smagorinsky and Leith schemes @@ -1805,23 +1782,19 @@ subroutine hor_visc_init(Time, G, US, param_file, diag, CS, MEKE) if (CS%Leith_Kh) CS%Laplac3_const_xx(i,j) = Leith_Lap_const * grid_sp_h3 ! Maximum of constant background and MICOM viscosity CS%Kh_bg_xx(i,j) = MAX(Kh, Kh_vel_scale * sqrt(grid_sp_h2)) - ! Use the larger of the above and values read from a file if (CS%use_Kh_bg_2d) CS%Kh_bg_xx(i,j) = MAX(CS%Kh_bg_2d(i,j), CS%Kh_bg_xx(i,j)) - ! Use the larger of the above and a function of sin(latitude) if (Kh_sin_lat>0.) then slat_fn = abs( sin( deg2rad * G%geoLatT(i,j) ) ) ** Kh_pwr_of_sine CS%Kh_bg_xx(i,j) = MAX(Kh_sin_lat * slat_fn, CS%Kh_bg_xx(i,j)) endif - if (CS%bound_Kh .and. .not.CS%better_bound_Kh) then ! Limit the background viscosity to be numerically stable CS%Kh_Max_xx(i,j) = Kh_Limit * grid_sp_h2 CS%Kh_bg_xx(i,j) = MIN(CS%Kh_bg_xx(i,j), CS%Kh_Max_xx(i,j)) endif enddo ; enddo - ! Calculate and store the background viscosity at q-points do J=js-1,Jeq ; do I=is-1,Ieq ! Static factors in the Smagorinsky and Leith schemes @@ -1831,17 +1804,14 @@ subroutine hor_visc_init(Time, G, US, param_file, diag, CS, MEKE) if (CS%Leith_Kh) CS%Laplac3_const_xy(I,J) = Leith_Lap_const * grid_sp_q3 ! Maximum of constant background and MICOM viscosity CS%Kh_bg_xy(I,J) = MAX(Kh, Kh_vel_scale * sqrt(grid_sp_q2)) - ! Use the larger of the above and values read from a file !### This expression uses inconsistent staggering if (CS%use_Kh_bg_2d) CS%Kh_bg_xy(I,J) = MAX(CS%Kh_bg_2d(i,j), CS%Kh_bg_xy(I,J)) - ! Use the larger of the above and a function of sin(latitude) if (Kh_sin_lat>0.) then slat_fn = abs( sin( deg2rad * G%geoLatBu(I,J) ) ) ** Kh_pwr_of_sine CS%Kh_bg_xy(I,J) = MAX(Kh_sin_lat * slat_fn, CS%Kh_bg_xy(I,J)) endif - if (CS%bound_Kh .and. .not.CS%better_bound_Kh) then ! Limit the background viscosity to be numerically stable CS%Kh_Max_xy(I,J) = Kh_Limit * grid_sp_q2 @@ -1849,9 +1819,7 @@ subroutine hor_visc_init(Time, G, US, param_file, diag, CS, MEKE) endif enddo ; enddo endif - if (CS%biharmonic) then - do j=js-1,Jeq+1 ; do I=Isq-1,Ieq+1 CS%Idx2dyCu(I,j) = (G%IdxCu(I,j)*G%IdxCu(I,j)) * G%IdyCu(I,j) CS%Idxdy2u(I,j) = G%IdxCu(I,j) * (G%IdyCu(I,j)*G%IdyCu(I,j)) @@ -1860,7 +1828,6 @@ subroutine hor_visc_init(Time, G, US, param_file, diag, CS, MEKE) CS%Idx2dyCv(i,J) = (G%IdxCv(i,J)*G%IdxCv(i,J)) * G%IdyCv(i,J) CS%Idxdy2v(i,J) = G%IdxCv(i,J) * (G%IdyCv(i,J)*G%IdyCv(i,J)) enddo ; enddo - CS%Ah_bg_xy(:,:) = 0.0 ! The 0.3 below was 0.4 in MOM1.10. The change in hq requires ! this to be less than 1/3, rather than 1/2 as before. @@ -1870,7 +1837,6 @@ subroutine hor_visc_init(Time, G, US, param_file, diag, CS, MEKE) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 grid_sp_h2 = (2.0*CS%dx2h(i,j)*CS%dy2h(i,j)) / (CS%dx2h(i,j)+CS%dy2h(i,j)) grid_sp_h3 = grid_sp_h2*sqrt(grid_sp_h2) - if (CS%Smagorinsky_Ah) then CS%Biharm_const_xx(i,j) = Smag_bi_const * (grid_sp_h2 * grid_sp_h2) if (CS%bound_Coriolis) then @@ -1884,6 +1850,7 @@ subroutine hor_visc_init(Time, G, US, param_file, diag, CS, MEKE) CS%biharm5_const_xx(i,j) = Leith_bi_const * (grid_sp_h3 * grid_sp_h2) endif CS%Ah_bg_xx(i,j) = MAX(Ah, Ah_vel_scale * grid_sp_h2 * sqrt(grid_sp_h2)) + if (CS%Re_Ah > 0.0) CS%Re_Ah_const_xx(i,j) = grid_sp_h3 / CS%Re_Ah if (Ah_time_scale > 0.) CS%Ah_bg_xx(i,j) = & MAX(CS%Ah_bg_xx(i,j), (grid_sp_h2 * grid_sp_h2) / Ah_time_scale) if (CS%bound_Ah .and. .not.CS%better_bound_Ah) then @@ -1894,7 +1861,6 @@ subroutine hor_visc_init(Time, G, US, param_file, diag, CS, MEKE) do J=js-1,Jeq ; do I=is-1,Ieq grid_sp_q2 = (2.0*CS%dx2q(I,J)*CS%dy2q(I,J)) / (CS%dx2q(I,J)+CS%dy2q(I,J)) grid_sp_q3 = grid_sp_q2*sqrt(grid_sp_q2) - if (CS%Smagorinsky_Ah) then CS%Biharm_const_xy(I,J) = Smag_bi_const * (grid_sp_q2 * grid_sp_q2) if (CS%bound_Coriolis) then @@ -1905,8 +1871,8 @@ subroutine hor_visc_init(Time, G, US, param_file, diag, CS, MEKE) if (CS%Leith_Ah) then CS%biharm5_const_xy(i,j) = Leith_bi_const * (grid_sp_q3 * grid_sp_q2) endif - CS%Ah_bg_xy(I,J) = MAX(Ah, Ah_vel_scale * grid_sp_q2 * sqrt(grid_sp_q2)) + if (CS%Re_Ah > 0.0) CS%Re_Ah_const_xy(i,j) = grid_sp_q3 / CS%Re_Ah if (Ah_time_scale > 0.) CS%Ah_bg_xy(i,j) = & MAX(CS%Ah_bg_xy(i,j), (grid_sp_q2 * grid_sp_q2) / Ah_time_scale) if (CS%bound_Ah .and. .not.CS%better_bound_Ah) then @@ -1915,7 +1881,6 @@ subroutine hor_visc_init(Time, G, US, param_file, diag, CS, MEKE) endif enddo ; enddo endif - ! The Laplacian bounds should avoid overshoots when CS%bound_coef < 1. if (CS%Laplacian .and. CS%better_bound_Kh) then Idt = 1.0 / dt @@ -1944,7 +1909,6 @@ subroutine hor_visc_init(Time, G, US, param_file, diag, CS, MEKE) call Bchksum(CS%Kh_Max_xy, "Kh_Max_xy", G%HI, haloshift=0, scale=US%L_to_m**2*US%s_to_T) endif endif - ! The biharmonic bounds should avoid overshoots when CS%bound_coef < 0.5, but ! empirically work for CS%bound_coef <~ 1.0 if (CS%biharmonic .and. CS%better_bound_Ah) then @@ -1954,7 +1918,6 @@ subroutine hor_visc_init(Time, G, US, param_file, diag, CS, MEKE) CS%dy2h(i,j) * CS%DY_dxT(i,j) * (G%IdyCu(I,j) + G%IdyCu(I-1,j)) ) + & CS%Idx2dyCu(I,j)*(CS%dx2q(I,J) * CS%DX_dyBu(I,J) * (G%IdxCu(I,j+1) + G%IdxCu(I,j)) + & CS%dx2q(I,J-1)*CS%DX_dyBu(I,J-1)*(G%IdxCu(I,j) + G%IdxCu(I,j-1)) ) ) - u0v(I,j) = (CS%Idxdy2u(I,j)*(CS%dy2h(i+1,j)*CS%DX_dyT(i+1,j)*(G%IdxCv(i+1,J) + G%IdxCv(i+1,J-1)) + & CS%dy2h(i,j) * CS%DX_dyT(i,j) * (G%IdxCv(i,J) + G%IdxCv(i,J-1)) ) + & CS%Idx2dyCu(I,j)*(CS%dx2q(I,J) * CS%DY_dxBu(I,J) * (G%IdyCv(i+1,J) + G%IdyCv(i,J)) + & @@ -1965,13 +1928,11 @@ subroutine hor_visc_init(Time, G, US, param_file, diag, CS, MEKE) CS%dy2q(I-1,J)*CS%DX_dyBu(I-1,J)*(G%IdxCu(I-1,j+1) + G%IdxCu(I-1,j)) ) + & CS%Idx2dyCv(i,J)*(CS%dx2h(i,j+1)*CS%DY_dxT(i,j+1)*(G%IdyCu(I,j+1) + G%IdyCu(I-1,j+1)) + & CS%dx2h(i,j) * CS%DY_dxT(i,j) * (G%IdyCu(I,j) + G%IdyCu(I-1,j)) ) ) - v0v(i,J) = (CS%Idxdy2v(i,J)*(CS%dy2q(I,J) * CS%DY_dxBu(I,J) * (G%IdyCv(i+1,J) + G%IdyCv(i,J)) + & CS%dy2q(I-1,J)*CS%DY_dxBu(I-1,J)*(G%IdyCv(i,J) + G%IdyCv(i-1,J)) ) + & CS%Idx2dyCv(i,J)*(CS%dx2h(i,j+1)*CS%DX_dyT(i,j+1)*(G%IdxCv(i,J+1) + G%IdxCv(i,J)) + & CS%dx2h(i,j) * CS%DX_dyT(i,j) * (G%IdxCv(i,J) + G%IdxCv(i,J-1)) ) ) enddo ; enddo - do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 denom = max( & (CS%dy2h(i,j) * & @@ -1986,7 +1947,6 @@ subroutine hor_visc_init(Time, G, US, param_file, diag, CS, MEKE) if (denom > 0.0) & CS%Ah_Max_xx(I,J) = CS%bound_coef * 0.5 * Idt / denom enddo ; enddo - do J=js-1,Jeq ; do I=is-1,Ieq denom = max( & (CS%dx2q(I,J) * & @@ -2006,74 +1966,56 @@ subroutine hor_visc_init(Time, G, US, param_file, diag, CS, MEKE) call Bchksum(CS%Ah_Max_xy, "Ah_Max_xy", G%HI, haloshift=0, scale=US%L_to_m**4*US%s_to_T) endif endif - ! Register fields for output from this module. - CS%id_diffu = register_diag_field('ocean_model', 'diffu', diag%axesCuL, Time, & 'Zonal Acceleration from Horizontal Viscosity', 'm s-2', conversion=US%L_T2_to_m_s2) - CS%id_diffv = register_diag_field('ocean_model', 'diffv', diag%axesCvL, Time, & 'Meridional Acceleration from Horizontal Viscosity', 'm s-2', conversion=US%L_T2_to_m_s2) - if (CS%biharmonic) then CS%id_Ah_h = register_diag_field('ocean_model', 'Ahh', diag%axesTL, Time, & 'Biharmonic Horizontal Viscosity at h Points', 'm4 s-1', conversion=US%L_to_m**4*US%s_to_T, & cmor_field_name='difmxybo', & cmor_long_name='Ocean lateral biharmonic viscosity', & cmor_standard_name='ocean_momentum_xy_biharmonic_diffusivity') - CS%id_Ah_q = register_diag_field('ocean_model', 'Ahq', diag%axesBL, Time, & 'Biharmonic Horizontal Viscosity at q Points', 'm4 s-1', conversion=US%L_to_m**4*US%s_to_T) endif - if (CS%Laplacian) then CS%id_Kh_h = register_diag_field('ocean_model', 'Khh', diag%axesTL, Time, & 'Laplacian Horizontal Viscosity at h Points', 'm2 s-1', conversion=US%L_to_m**2*US%s_to_T, & cmor_field_name='difmxylo', & cmor_long_name='Ocean lateral Laplacian viscosity', & cmor_standard_name='ocean_momentum_xy_laplacian_diffusivity') - CS%id_Kh_q = register_diag_field('ocean_model', 'Khq', diag%axesBL, Time, & 'Laplacian Horizontal Viscosity at q Points', 'm2 s-1', conversion=US%L_to_m**2*US%s_to_T) - if (CS%Leith_Kh) then CS%id_vort_xy_q = register_diag_field('ocean_model', 'vort_xy_q', diag%axesBL, Time, & 'Vertical vorticity at q Points', 's-1', conversion=US%s_to_T) - CS%id_div_xx_h = register_diag_field('ocean_model', 'div_xx_h', diag%axesTL, Time, & 'Horizontal divergence at h Points', 's-1', conversion=US%s_to_T) endif - endif - if (CS%use_GME) then CS%id_GME_coeff_h = register_diag_field('ocean_model', 'GME_coeff_h', diag%axesTL, Time, & 'GME coefficient at h Points', 'm2 s-1', conversion=US%L_to_m**2*US%s_to_T) - CS%id_GME_coeff_q = register_diag_field('ocean_model', 'GME_coeff_q', diag%axesBL, Time, & 'GME coefficient at q Points', 'm2 s-1', conversion=US%L_to_m**2*US%s_to_T) - CS%id_FrictWork_GME = register_diag_field('ocean_model','FrictWork_GME',diag%axesTL,Time,& 'Integral work done by lateral friction terms in GME (excluding diffusion of energy)', & 'W m-2', conversion=US%R_to_kg_m3*US%Z_to_m*US%s_to_T**3*US%L_to_m**2) endif - CS%id_FrictWork = register_diag_field('ocean_model','FrictWork',diag%axesTL,Time,& 'Integral work done by lateral friction terms', & 'W m-2', conversion=US%R_to_kg_m3*US%Z_to_m*US%s_to_T**3*US%L_to_m**2) - CS%id_FrictWorkIntz = register_diag_field('ocean_model','FrictWorkIntz',diag%axesT1,Time, & 'Depth integrated work done by lateral friction', & 'W m-2', conversion=US%R_to_kg_m3*US%Z_to_m*US%s_to_T**3*US%L_to_m**2, & cmor_field_name='dispkexyfo', & cmor_long_name='Depth integrated ocean kinetic energy dissipation due to lateral friction',& cmor_standard_name='ocean_kinetic_energy_dissipation_per_unit_area_due_to_xy_friction') - if (CS%Laplacian .or. get_all) then endif - end subroutine hor_visc_init - !> Calculates factors in the anisotropic orientation tensor to be align with the grid. !! With n1=1 and n2=0, this recovers the approach of Large et al, 2001. subroutine align_aniso_tensor_to_grid(CS, n1, n2) @@ -2082,18 +2024,14 @@ subroutine align_aniso_tensor_to_grid(CS, n1, n2) real, intent(in) :: n2 !< j-component of direction vector [nondim] ! Local variables real :: recip_n2_norm - ! For normalizing n=(n1,n2) in case arguments are not a unit vector recip_n2_norm = n1**2 + n2**2 if (recip_n2_norm > 0.) recip_n2_norm = 1./recip_n2_norm - CS%n1n2_h(:,:) = 2. * ( n1 * n2 ) * recip_n2_norm CS%n1n2_q(:,:) = 2. * ( n1 * n2 ) * recip_n2_norm CS%n1n1_m_n2n2_h(:,:) = ( n1 * n1 - n2 * n2 ) * recip_n2_norm CS%n1n1_m_n2n2_q(:,:) = ( n1 * n1 - n2 * n2 ) * recip_n2_norm - end subroutine align_aniso_tensor_to_grid - !> Apply a 1-1-4-1-1 Laplacian filter one time on GME diffusive flux to reduce any !! horizontal two-grid-point noise subroutine smooth_GME(CS,G,GME_flux_h,GME_flux_q) @@ -2104,15 +2042,12 @@ subroutine smooth_GME(CS,G,GME_flux_h,GME_flux_q) !! at h points real, dimension(SZIB_(G),SZJB_(G)), optional, intent(inout) :: GME_flux_q!< GME diffusive flux !! at q points - ! local variables real, dimension(SZI_(G),SZJ_(G)) :: GME_flux_h_original real, dimension(SZIB_(G),SZJB_(G)) :: GME_flux_q_original real :: wc, ww, we, wn, ws ! averaging weights for smoothing integer :: i, j, k, s - do s=1,1 - ! Update halos if (present(GME_flux_h)) then call pass_var(GME_flux_h, G%Domain) @@ -2122,14 +2057,12 @@ subroutine smooth_GME(CS,G,GME_flux_h,GME_flux_q) do i = G%isc, G%iec ! skip land points if (G%mask2dT(i,j)==0.) cycle - ! compute weights ww = 0.125 * G%mask2dT(i-1,j) we = 0.125 * G%mask2dT(i+1,j) ws = 0.125 * G%mask2dT(i,j-1) wn = 0.125 * G%mask2dT(i,j+1) wc = 1.0 - (ww+we+wn+ws) - GME_flux_h(i,j) = wc * GME_flux_h_original(i,j) & + ww * GME_flux_h_original(i-1,j) & + we * GME_flux_h_original(i+1,j) & @@ -2137,7 +2070,6 @@ subroutine smooth_GME(CS,G,GME_flux_h,GME_flux_q) + wn * GME_flux_h_original(i,j+1) enddo; enddo endif - ! Update halos if (present(GME_flux_q)) then call pass_var(GME_flux_q, G%Domain, position=CORNER, complete=.true.) @@ -2147,14 +2079,12 @@ subroutine smooth_GME(CS,G,GME_flux_h,GME_flux_q) do I = G%IscB, G%IecB ! skip land points if (G%mask2dBu(I,J)==0.) cycle - ! compute weights ww = 0.125 * G%mask2dBu(I-1,J) we = 0.125 * G%mask2dBu(I+1,J) ws = 0.125 * G%mask2dBu(I,J-1) wn = 0.125 * G%mask2dBu(I,J+1) wc = 1.0 - (ww+we+wn+ws) - GME_flux_q(I,J) = wc * GME_flux_q_original(I,J) & + ww * GME_flux_q_original(I-1,J) & + we * GME_flux_q_original(I+1,J) & @@ -2162,22 +2092,17 @@ subroutine smooth_GME(CS,G,GME_flux_h,GME_flux_q) + wn * GME_flux_q_original(I,J+1) enddo; enddo endif - enddo ! s-loop - end subroutine smooth_GME - !> Deallocates any variables allocated in hor_visc_init. subroutine hor_visc_end(CS) type(hor_visc_CS), pointer :: CS !< The control structure returned by a !! previous call to hor_visc_init. - if (CS%Laplacian .or. CS%biharmonic) then DEALLOC_(CS%dx2h) ; DEALLOC_(CS%dx2q) ; DEALLOC_(CS%dy2h) ; DEALLOC_(CS%dy2q) DEALLOC_(CS%dx_dyT) ; DEALLOC_(CS%dy_dxT) ; DEALLOC_(CS%dx_dyBu) ; DEALLOC_(CS%dy_dxBu) DEALLOC_(CS%reduction_xx) ; DEALLOC_(CS%reduction_xy) endif - if (CS%Laplacian) then DEALLOC_(CS%Kh_bg_xx) ; DEALLOC_(CS%Kh_bg_xy) if (CS%bound_Kh) then @@ -2190,7 +2115,6 @@ subroutine hor_visc_end(CS) DEALLOC_(CS%Laplac3_const_xx) ; DEALLOC_(CS%Laplac3_const_xy) endif endif - if (CS%biharmonic) then DEALLOC_(CS%Idx2dyCu) ; DEALLOC_(CS%Idx2dyCv) DEALLOC_(CS%Idxdy2u) ; DEALLOC_(CS%Idxdy2v) @@ -2207,6 +2131,9 @@ subroutine hor_visc_end(CS) if (CS%Leith_Ah) then DEALLOC_(CS%Biharm_const_xx) ; DEALLOC_(CS%Biharm_const_xy) endif + if (CS%Re_Ah > 0.0) then + DEALLOC_(CS%Re_Ah_const_xx) ; DEALLOC_(CS%Re_Ah_const_xy) + endif endif if (CS%anisotropic) then DEALLOC_(CS%n1n2_h) @@ -2215,10 +2142,7 @@ subroutine hor_visc_end(CS) DEALLOC_(CS%n1n1_m_n2n2_q) endif deallocate(CS) - end subroutine hor_visc_end - - !> \namespace mom_hor_visc !! !! This module contains the subroutine horizontal_viscosity() that calculates the @@ -2519,5 +2443,4 @@ end subroutine hor_visc_end !! Smith, R.D., and McWilliams, J.C., 2003: Anisotropic horizontal viscosity for !! ocean models. Ocean Modelling, 5(2), 129-156. !! https://doi.org/10.1016/S1463-5003(02)00016-1 - end module MOM_hor_visc From c325f9c1bf182fc89bb47e5f4c84e5a7878c58a9 Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Wed, 15 Apr 2020 22:30:32 +0000 Subject: [PATCH 195/316] Removes G_EARTH from OBCs - The parameter G_EARTH is unnecessarily read and logged by OBCs. This is normally innocuous except PR #1088 rearranges the call order between OBCs and vertGrid which puts G_EARTH in the wrong block in the doc files. - This removes G_EARTH from OBCs so it is not logged and the two outstanding PRs (#1088 and #1089) don't move G_EARTH to the wrong place. - This PR on its own does not change the doc files prior to #1088. --- src/core/MOM_open_boundary.F90 | 4 ---- 1 file changed, 4 deletions(-) diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index 3b1559ab81..6ebb17baa8 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -240,7 +240,6 @@ module MOM_open_boundary 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. - real :: g_Earth !< The gravitational acceleration [m s-2]. logical, pointer, dimension(:) :: & tracer_x_reservoirs_used => NULL() !< Dimensioned by the number of tracers, set globally, !! true for those with x reservoirs (needed for restarts). @@ -347,9 +346,6 @@ subroutine open_boundary_config(G, US, param_file, OBC) call get_param(param_file, mdl, "OBC_NUMBER_OF_SEGMENTS", OBC%number_of_segments, & "The number of open boundary segments.", & default=0) - call get_param(param_file, mdl, "G_EARTH", OBC%g_Earth, & - "The gravitational acceleration of the Earth.", & - units="m s-2", default = 9.80) call get_param(param_file, mdl, "OBC_USER_CONFIG", config1, & "A string that sets how the open boundary conditions are "//& " configured: \n", default="none", do_not_log=.true.) From b4c4f28aa75956cc42029bebbb3d16929fdaf347 Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Thu, 16 Apr 2020 13:19:20 +0000 Subject: [PATCH 196/316] Resolve conflict with NOAA-GFDL/MOM6#1088 - This branch/PR had been setup to precede NOAA-GFDL/MOM6#1088 to minimize changes to MOM6-examples but @Hallberg-NOAA jumped the gun and merged the PRs out of order. - This commit resolves the conflict and MOM6-examples needs to be fixed. --- src/core/MOM_open_boundary.F90 | 1 - 1 file changed, 1 deletion(-) diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index 3f529acf94..ffede1c0c2 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -4935,7 +4935,6 @@ subroutine rotate_OBC_config(OBC_in, G_in, OBC, G, turns) ! Scalar and logical transfer OBC%number_of_segments = OBC_in%number_of_segments - OBC%g_Earth = OBC_in%g_Earth OBC%ke = OBC_in%ke OBC%user_BCs_set_globally = OBC_in%user_BCs_set_globally From 68c53e9bb65e1f2c35786d75a12a0ac8f855b300 Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Thu, 16 Apr 2020 15:56:53 +0000 Subject: [PATCH 197/316] Removes missing_value argument from APIs in MOM_diag_remap - missing_value was a argument to several functions in MOM_diag_remap but was not used. At one point these functions incorrectly used missing_value to mask data but this is not the correct usage of missing_value not the right way to use masking in MOM6. This was fixed 3 years ago and this commit simply removes unused arguments. --- src/framework/MOM_diag_mediator.F90 | 10 +++++----- src/framework/MOM_diag_remap.F90 | 12 ++++-------- 2 files changed, 9 insertions(+), 13 deletions(-) diff --git a/src/framework/MOM_diag_mediator.F90 b/src/framework/MOM_diag_mediator.F90 index ceb782ce4b..b03271b4d7 100644 --- a/src/framework/MOM_diag_mediator.F90 +++ b/src/framework/MOM_diag_mediator.F90 @@ -1505,7 +1505,7 @@ subroutine post_data_3d(diag_field_id, field, diag_cs, is_static, mask, alt_h) call vertically_reintegrate_diag_field( & diag_cs%diag_remap_cs(diag%axes%vertical_coordinate_number), & diag_cs%G, h_diag, staggered_in_x, staggered_in_y, & - diag%axes%mask3d, diag_cs%missing_value, field, remapped_field) + diag%axes%mask3d, field, remapped_field) if (id_clock_diag_remap>0) call cpu_clock_end(id_clock_diag_remap) if (associated(diag%axes%mask3d)) then ! Since 3d masks do not vary in the vertical, just use as much as is @@ -1528,7 +1528,7 @@ subroutine post_data_3d(diag_field_id, field, diag_cs, is_static, mask, alt_h) allocate(remapped_field(size(field,1), size(field,2), diag%axes%nz)) call diag_remap_do_remap(diag_cs%diag_remap_cs(diag%axes%vertical_coordinate_number), & diag_cs%G, diag_cs%GV, h_diag, staggered_in_x, staggered_in_y, & - diag%axes%mask3d, diag_cs%missing_value, field, remapped_field) + diag%axes%mask3d, field, remapped_field) if (id_clock_diag_remap>0) call cpu_clock_end(id_clock_diag_remap) if (associated(diag%axes%mask3d)) then ! Since 3d masks do not vary in the vertical, just use as much as is @@ -1552,7 +1552,7 @@ subroutine post_data_3d(diag_field_id, field, diag_cs, is_static, mask, alt_h) call vertically_interpolate_diag_field(diag_cs%diag_remap_cs( & diag%axes%vertical_coordinate_number), & diag_cs%G, h_diag, staggered_in_x, staggered_in_y, & - diag%axes%mask3d, diag_cs%missing_value, field, remapped_field) + diag%axes%mask3d, field, remapped_field) if (id_clock_diag_remap>0) call cpu_clock_end(id_clock_diag_remap) if (associated(diag%axes%mask3d)) then ! Since 3d masks do not vary in the vertical, just use as much as is @@ -1769,7 +1769,7 @@ subroutine post_xy_average(diag_cs, diag, field) call horizontally_average_diag_field(diag_cs%G, diag_cs%GV, diag_cs%h, & staggered_in_x, staggered_in_y, & diag%axes%is_layer, diag%v_extensive, & - diag_cs%missing_value, field, & + field, & averaged_field, averaged_mask) else nz = size(field, 3) @@ -1788,7 +1788,7 @@ subroutine post_xy_average(diag_cs, diag, field) diag_cs%diag_remap_cs(coord)%h, & staggered_in_x, staggered_in_y, & diag%axes%is_layer, diag%v_extensive, & - diag_cs%missing_value, field, & + field, & averaged_field, averaged_mask) endif diff --git a/src/framework/MOM_diag_remap.F90 b/src/framework/MOM_diag_remap.F90 index cadd74950a..64d34ba864 100644 --- a/src/framework/MOM_diag_remap.F90 +++ b/src/framework/MOM_diag_remap.F90 @@ -346,7 +346,7 @@ end subroutine diag_remap_update !> Remap diagnostic field to alternative vertical grid. subroutine diag_remap_do_remap(remap_cs, G, GV, h, staggered_in_x, staggered_in_y, & - mask, missing_value, field, remapped_field) + mask, field, remapped_field) type(diag_remap_ctrl), intent(in) :: remap_cs !< Diagnostic coodinate control structure type(ocean_grid_type), intent(in) :: G !< Ocean grid structure type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure @@ -354,7 +354,6 @@ subroutine diag_remap_do_remap(remap_cs, G, GV, h, staggered_in_x, staggered_in_ logical, intent(in) :: staggered_in_x !< True is the x-axis location is at u or q points logical, intent(in) :: staggered_in_y !< True is the y-axis location is at v or q points real, dimension(:,:,:), pointer :: mask !< A mask for the field - real, intent(in) :: missing_value !< A missing_value to assign land/vanished points real, dimension(:,:,:), intent(in) :: field(:,:,:) !< The diagnostic field to be remapped real, dimension(:,:,:), intent(inout) :: remapped_field !< Field remapped to new coordinate ! Local variables @@ -486,14 +485,13 @@ end subroutine diag_remap_calc_hmask !> Vertically re-grid an already vertically-integrated diagnostic field to alternative vertical grid. subroutine vertically_reintegrate_diag_field(remap_cs, G, h, staggered_in_x, staggered_in_y, & - mask, missing_value, field, reintegrated_field) + mask, field, reintegrated_field) type(diag_remap_ctrl), intent(in) :: remap_cs !< Diagnostic coodinate control structure type(ocean_grid_type), intent(in) :: G !< Ocean grid structure real, dimension(:,:,:), intent(in) :: h !< The current thicknesses logical, intent(in) :: staggered_in_x !< True is the x-axis location is at u or q points logical, intent(in) :: staggered_in_y !< True is the y-axis location is at v or q points real, dimension(:,:,:), pointer :: mask !< A mask for the field - real, intent(in) :: missing_value !< A missing_value to assign land/vanished points real, dimension(:,:,:), intent(in) :: field !< The diagnostic field to be remapped real, dimension(:,:,:), intent(inout) :: reintegrated_field !< Field argument remapped to alternative coordinate ! Local variables @@ -567,14 +565,13 @@ end subroutine vertically_reintegrate_diag_field !> Vertically interpolate diagnostic field to alternative vertical grid. subroutine vertically_interpolate_diag_field(remap_cs, G, h, staggered_in_x, staggered_in_y, & - mask, missing_value, field, interpolated_field) + mask, field, interpolated_field) type(diag_remap_ctrl), intent(in) :: remap_cs !< Diagnostic coodinate control structure type(ocean_grid_type), intent(in) :: G !< Ocean grid structure real, dimension(:,:,:), intent(in) :: h !< The current thicknesses logical, intent(in) :: staggered_in_x !< True is the x-axis location is at u or q points logical, intent(in) :: staggered_in_y !< True is the y-axis location is at v or q points real, dimension(:,:,:), pointer :: mask !< A mask for the field - real, intent(in) :: missing_value !< A missing_value to assign land/vanished points real, dimension(:,:,:), intent(in) :: field !< The diagnostic field to be remapped real, dimension(:,:,:), intent(inout) :: interpolated_field !< Field argument remapped to alternative coordinate ! Local variables @@ -650,7 +647,7 @@ end subroutine vertically_interpolate_diag_field !> Horizontally average field subroutine horizontally_average_diag_field(G, GV, h, staggered_in_x, staggered_in_y, & is_layer, is_extensive, & - missing_value, field, averaged_field, & + field, averaged_field, & averaged_mask) type(ocean_grid_type), intent(in) :: G !< Ocean grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean vertical grid structure @@ -659,7 +656,6 @@ subroutine horizontally_average_diag_field(G, GV, h, staggered_in_x, staggered_i logical, intent(in) :: staggered_in_y !< True if the y-axis location is at v or q points logical, intent(in) :: is_layer !< True if the z-axis location is at h points logical, intent(in) :: is_extensive !< True if the z-direction is spatially integrated (over layers) - real, intent(in) :: missing_value !< A missing_value to assign land/vanished points real, dimension(:,:,:), intent(in) :: field !< The diagnostic field to be remapped real, dimension(:), intent(inout) :: averaged_field !< Field argument horizontally averaged logical, dimension(:), intent(inout) :: averaged_mask !< Mask for horizontally averaged field From 65f36d76866904f53fb9f73a498365bcd2806e8f Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Thu, 16 Apr 2020 10:40:02 -0600 Subject: [PATCH 198/316] Add diags for Lapl. and Bihar grid Reynolds #s grid_Re_Kh = (U sqtr(dx2))/Kh grid_Re_Kh = (U dx3)/Ah where dx2 is the harmonic mean of the squares of the grid [L2], and dx3 is the harmonic mean of the squares of the grid^(3/2) [L3] --- .../lateral/MOM_hor_visc.F90 | 33 +++++++++++++++++-- 1 file changed, 30 insertions(+), 3 deletions(-) diff --git a/src/parameterizations/lateral/MOM_hor_visc.F90 b/src/parameterizations/lateral/MOM_hor_visc.F90 index f3c593819a..1458706316 100644 --- a/src/parameterizations/lateral/MOM_hor_visc.F90 +++ b/src/parameterizations/lateral/MOM_hor_visc.F90 @@ -117,8 +117,9 @@ module MOM_hor_visc Kh_Max_xx, & !< The maximum permitted Laplacian viscosity [L2 T-1 ~> m2 s-1]. Ah_Max_xx, & !< The maximum permitted biharmonic viscosity [L4 T-1 ~> m4 s-1]. n1n2_h, & !< Factor n1*n2 in the anisotropic direction tensor at h-points - n1n1_m_n2n2_h !< Factor n1**2-n2**2 in the anisotropic direction tensor at h-points - + n1n1_m_n2n2_h, & !< Factor n1**2-n2**2 in the anisotropic direction tensor at h-points + grid_sp_h2, & !< Harmonic mean of the squares of the grid [L2 ~> m2] + grid_sp_h3 !< Harmonic mean of the squares of the grid^(3/2) [L3 ~> m3] real ALLOCABLE_, dimension(NIMEMB_PTR_,NJMEMB_PTR_) :: Kh_bg_xy !< The background Laplacian viscosity at q points [L2 T-1 ~> m2 s-1]. !! The actual viscosity may be the larger of this @@ -180,6 +181,7 @@ module MOM_hor_visc !>@{ !! Diagnostic id + integer :: id_grid_Re_Ah = -1, id_grid_Re_Kh = -1 integer :: id_diffu = -1, id_diffv = -1 integer :: id_Ah_h = -1, id_Ah_q = -1 integer :: id_Kh_h = -1, id_Kh_q = -1 @@ -304,9 +306,11 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, Kh_h, & ! Laplacian viscosity at thickness points [L2 T-1 ~> m2 s-1] max_diss_rate_h, & ! maximum possible energy dissipated by lateral friction [L2 T-3 ~> m2 s-3] FrictWork, & ! work done by MKE dissipation mechanisms [R L2 T-3 ~> W m-2] - FrictWork_GME, & ! work done by GME [R L2 T-3 ~> W m-2] + FrictWork_GME, & ! work done by GME [R L2 T-3 ~> W m-2] div_xx_h ! horizontal divergence [T-1 ~> s-1] real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: & + grid_Re_Kh, & !< Grid Reynolds number for Laplacian horizontal viscosity at h points [nondim] + grid_Re_Ah, & !< Grid Reynolds number for Biharmonic horizontal viscosity at h points [nondim] GME_coeff_h !< GME coeff. at h-points [L2 T-1 ~> m2 s-1] real :: Ah ! biharmonic viscosity [L4 T-1 ~> m4 s-1] real :: Kh ! Laplacian viscosity [L2 T-1 ~> m2 s-1] @@ -842,6 +846,12 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, endif if ((CS%id_Kh_h>0) .or. find_FrictWork .or. CS%debug) Kh_h(i,j,k) = Kh + + if (CS%id_grid_Re_Kh>0) then + KE = 0.125*((u(I,j,k)+u(I-1,j,k))**2 + (v(i,J,k)+v(i,J-1,k))**2) + grid_Re_Kh(i,j,k) = (sqrt(KE) * sqrt(CS%grid_sp_h2(i,j)))/Kh + endif + if (CS%id_div_xx_h>0) div_xx_h(i,j,k) = div_xx(i,j) str_xx(i,j) = -Kh * sh_xx(i,j) @@ -890,6 +900,11 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, if ((CS%id_Ah_h>0) .or. find_FrictWork .or. CS%debug) Ah_h(i,j,k) = Ah + if (CS%id_grid_Re_Ah>0) then + KE = 0.125*((u(I,j,k)+u(I-1,j,k))**2 + (v(i,J,k)+v(i,J-1,k))**2) + grid_Re_Ah(i,j,k) = (sqrt(KE) * CS%grid_sp_h3(i,j))/Ah + endif + str_xx(i,j) = str_xx(i,j) + Ah * & (CS%DY_dxT(i,j) * (G%IdyCu(I,j)*Del2u(I,j) - G%IdyCu(I-1,j)*Del2u(I-1,j)) - & CS%DX_dyT(i,j) * (G%IdxCv(i,J)*Del2v(i,J) - G%IdxCv(i,J-1)*Del2v(i,J-1))) @@ -1295,10 +1310,12 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, if (CS%id_FrictWork>0) call post_data(CS%id_FrictWork, FrictWork, CS%diag) if (CS%id_FrictWork_GME>0) call post_data(CS%id_FrictWork_GME, FrictWork_GME, CS%diag) if (CS%id_Ah_h>0) call post_data(CS%id_Ah_h, Ah_h, CS%diag) + if (CS%id_grid_Re_Ah>0) call post_data(CS%id_grid_Re_Ah, grid_Re_Ah, CS%diag) if (CS%id_div_xx_h>0) call post_data(CS%id_div_xx_h, div_xx_h, CS%diag) if (CS%id_vort_xy_q>0) call post_data(CS%id_vort_xy_q, vort_xy_q, CS%diag) if (CS%id_Ah_q>0) call post_data(CS%id_Ah_q, Ah_q, CS%diag) if (CS%id_Kh_h>0) call post_data(CS%id_Kh_h, Kh_h, CS%diag) + if (CS%id_grid_Re_Kh>0) call post_data(CS%id_grid_Re_Kh, grid_Re_Kh, CS%diag) if (CS%id_Kh_q>0) call post_data(CS%id_Kh_q, Kh_q, CS%diag) if (CS%id_GME_coeff_h > 0) call post_data(CS%id_GME_coeff_h, GME_coeff_h, CS%diag) if (CS%id_GME_coeff_q > 0) call post_data(CS%id_GME_coeff_q, GME_coeff_q, CS%diag) @@ -1658,6 +1675,7 @@ subroutine hor_visc_init(Time, G, US, param_file, diag, CS, MEKE) ALLOC_(CS%dx_dyBu(IsdB:IedB,JsdB:JedB)) ; CS%dx_dyBu(:,:) = 0.0 ALLOC_(CS%dy_dxBu(IsdB:IedB,JsdB:JedB)) ; CS%dy_dxBu(:,:) = 0.0 if (CS%Laplacian) then + ALLOC_(CS%grid_sp_h2(isd:ied,jsd:jed)) ; CS%grid_sp_h2(:,:) = 0.0 ALLOC_(CS%Kh_bg_xx(isd:ied,jsd:jed)) ; CS%Kh_bg_xx(:,:) = 0.0 ALLOC_(CS%Kh_bg_xy(IsdB:IedB,JsdB:JedB)) ; CS%Kh_bg_xy(:,:) = 0.0 if (CS%bound_Kh .or. CS%better_bound_Kh) then @@ -1710,6 +1728,7 @@ subroutine hor_visc_init(Time, G, US, param_file, diag, CS, MEKE) ALLOC_(CS%Idxdy2v(isd:ied,JsdB:JedB)) ; CS%Idxdy2v(:,:) = 0.0 ALLOC_(CS%Ah_bg_xx(isd:ied,jsd:jed)) ; CS%Ah_bg_xx(:,:) = 0.0 ALLOC_(CS%Ah_bg_xy(IsdB:IedB,JsdB:JedB)) ; CS%Ah_bg_xy(:,:) = 0.0 + ALLOC_(CS%grid_sp_h3(IsdB:IedB,JsdB:JedB)); CS%grid_sp_h3(:,:) = 0.0 if (CS%bound_Ah .or. CS%better_bound_Ah) then ALLOC_(CS%Ah_Max_xx(isd:ied,jsd:jed)) ; CS%Ah_Max_xx(:,:) = 0.0 ALLOC_(CS%Ah_Max_xy(IsdB:IedB,JsdB:JedB)) ; CS%Ah_Max_xy(:,:) = 0.0 @@ -1777,6 +1796,7 @@ subroutine hor_visc_init(Time, G, US, param_file, diag, CS, MEKE) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 ! Static factors in the Smagorinsky and Leith schemes grid_sp_h2 = (2.0*CS%dx2h(i,j)*CS%dy2h(i,j)) / (CS%dx2h(i,j) + CS%dy2h(i,j)) + CS%grid_sp_h2(i,j) = grid_sp_h2 grid_sp_h3 = grid_sp_h2*sqrt(grid_sp_h2) if (CS%Smagorinsky_Kh) CS%Laplac2_const_xx(i,j) = Smag_Lap_const * grid_sp_h2 if (CS%Leith_Kh) CS%Laplac3_const_xx(i,j) = Leith_Lap_const * grid_sp_h3 @@ -1837,6 +1857,7 @@ subroutine hor_visc_init(Time, G, US, param_file, diag, CS, MEKE) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 grid_sp_h2 = (2.0*CS%dx2h(i,j)*CS%dy2h(i,j)) / (CS%dx2h(i,j)+CS%dy2h(i,j)) grid_sp_h3 = grid_sp_h2*sqrt(grid_sp_h2) + CS%grid_sp_h3(i,j) = grid_sp_h3 if (CS%Smagorinsky_Ah) then CS%Biharm_const_xx(i,j) = Smag_bi_const * (grid_sp_h2 * grid_sp_h2) if (CS%bound_Coriolis) then @@ -1979,6 +2000,8 @@ subroutine hor_visc_init(Time, G, US, param_file, diag, CS, MEKE) cmor_standard_name='ocean_momentum_xy_biharmonic_diffusivity') CS%id_Ah_q = register_diag_field('ocean_model', 'Ahq', diag%axesBL, Time, & 'Biharmonic Horizontal Viscosity at q Points', 'm4 s-1', conversion=US%L_to_m**4*US%s_to_T) + CS%id_grid_Re_Ah = register_diag_field('ocean_model', 'grid_Re_Ah', diag%axesTL, Time, & + 'Grid Reynolds number for the Biharmonic horizontal viscosity at h points', 'nondim') endif if (CS%Laplacian) then CS%id_Kh_h = register_diag_field('ocean_model', 'Khh', diag%axesTL, Time, & @@ -1988,6 +2011,8 @@ subroutine hor_visc_init(Time, G, US, param_file, diag, CS, MEKE) cmor_standard_name='ocean_momentum_xy_laplacian_diffusivity') CS%id_Kh_q = register_diag_field('ocean_model', 'Khq', diag%axesBL, Time, & 'Laplacian Horizontal Viscosity at q Points', 'm2 s-1', conversion=US%L_to_m**2*US%s_to_T) + CS%id_grid_Re_Kh = register_diag_field('ocean_model', 'grid_Re_Kh', diag%axesTL, Time, & + 'Grid Reynolds number for the Laplacian horizontal viscosity at h points', 'nondim') if (CS%Leith_Kh) then CS%id_vort_xy_q = register_diag_field('ocean_model', 'vort_xy_q', diag%axesBL, Time, & 'Vertical vorticity at q Points', 's-1', conversion=US%s_to_T) @@ -2105,6 +2130,7 @@ subroutine hor_visc_end(CS) endif if (CS%Laplacian) then DEALLOC_(CS%Kh_bg_xx) ; DEALLOC_(CS%Kh_bg_xy) + DEALLOC_(CS%grid_sp_h2) if (CS%bound_Kh) then DEALLOC_(CS%Kh_Max_xx) ; DEALLOC_(CS%Kh_Max_xy) endif @@ -2116,6 +2142,7 @@ subroutine hor_visc_end(CS) endif endif if (CS%biharmonic) then + DEALLOC_(CS%grid_sp_h3) DEALLOC_(CS%Idx2dyCu) ; DEALLOC_(CS%Idx2dyCv) DEALLOC_(CS%Idxdy2u) ; DEALLOC_(CS%Idxdy2v) DEALLOC_(CS%Ah_bg_xx) ; DEALLOC_(CS%Ah_bg_xy) From 49ab54ab5a6491728dd0b6b60ac58e6e87739e92 Mon Sep 17 00:00:00 2001 From: alperaltuntas Date: Fri, 17 Apr 2020 08:21:24 -0600 Subject: [PATCH 199/316] move pass_var in KPP smoothing outside the do-loop --- src/parameterizations/vertical/MOM_CVMix_KPP.F90 | 11 ++++++++--- 1 file changed, 8 insertions(+), 3 deletions(-) diff --git a/src/parameterizations/vertical/MOM_CVMix_KPP.F90 b/src/parameterizations/vertical/MOM_CVMix_KPP.F90 index 6056dd3eab..8151511bbf 100644 --- a/src/parameterizations/vertical/MOM_CVMix_KPP.F90 +++ b/src/parameterizations/vertical/MOM_CVMix_KPP.F90 @@ -225,6 +225,11 @@ logical function KPP_init(paramFile, G, GV, US, diag, Time, CS, passive, Waves) 'The number of times the 1-1-4-1-1 Laplacian filter is applied on '// & 'OBL depth.', & default=0) + if ((CS%n_smooth > G%domain%nihalo) then + call MOM_error(FATAL,'KPP smoothing number (N_SMOOTH) cannot be greater than NIHALO.') + elseif ((CS%n_smooth > G%domain%njhalo) then + call MOM_error(FATAL,'KPP smoothing number (N_SMOOTH) cannot be greater than NJHALO.') + endif 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 '// & @@ -1362,10 +1367,10 @@ subroutine KPP_smooth_BLD(CS,G,GV,h) real :: pref integer :: i, j, k, s - do s=1,CS%n_smooth + ! Update halos + call pass_var(CS%OBLdepth, G%Domain, halo=CS%n_smooth) - ! Update halos - call pass_var(CS%OBLdepth, G%Domain) + do s=1,CS%n_smooth OBLdepth_original = CS%OBLdepth if (CS%id_OBLdepth_original > 0) CS%OBLdepth_original = OBLdepth_original From ab9d8e95ffc695f2d5c9feed388ec708c4563bf7 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 17 Apr 2020 11:05:11 -0400 Subject: [PATCH 200/316] +Added dom interface to calculate_density Removed the interfaces using G%HI to calculate_density and related routines and added a new variant with a new optional argument 'dom' specifying a two- element integer array with the start and end values of the domain to compute on for 1-d arrays starting at 1. If this array is not present in this new variant, calculations are done over the entire output array extent. All calls to the interfaces from before the rescale_pressure pull request will still work. Also added the new function EOS_domain that sets this two-element domain array from a horiz_index_type. This new interface is used throughout the code where the old, removed form was in use. All answers are bitwise identical. --- src/ALE/coord_hycom.F90 | 2 +- src/ALE/coord_rho.F90 | 2 +- src/ALE/coord_slight.F90 | 10 +- src/core/MOM.F90 | 6 +- src/core/MOM_forcing_type.F90 | 6 +- src/diagnostics/MOM_diagnostics.F90 | 19 +- src/equation_of_state/MOM_EOS.F90 | 399 +++++++++--------- src/ice_shelf/MOM_ice_shelf.F90 | 10 +- .../MOM_state_initialization.F90 | 16 +- .../lateral/MOM_mixed_layer_restrat.F90 | 16 +- .../lateral/MOM_thickness_diffuse.F90 | 10 +- .../vertical/MOM_CVMix_ddiff.F90 | 3 +- .../vertical/MOM_bulk_mixed_layer.F90 | 15 +- .../vertical/MOM_diabatic_aux.F90 | 23 +- .../vertical/MOM_diabatic_driver.F90 | 6 +- .../vertical/MOM_diapyc_energy_req.F90 | 2 +- .../vertical/MOM_energetic_PBL.F90 | 2 - .../vertical/MOM_entrain_diffusive.F90 | 15 +- .../vertical/MOM_full_convection.F90 | 15 +- .../vertical/MOM_internal_tide_input.F90 | 6 +- .../vertical/MOM_kappa_shear.F90 | 6 +- .../vertical/MOM_regularize_layers.F90 | 8 +- .../vertical/MOM_set_diffusivity.F90 | 21 +- .../vertical/MOM_set_viscosity.F90 | 18 +- src/tracer/MOM_neutral_diffusion.F90 | 16 +- src/tracer/MOM_tracer_hor_diff.F90 | 6 +- src/user/RGC_initialization.F90 | 5 +- src/user/user_change_diffusivity.F90 | 8 +- 28 files changed, 337 insertions(+), 334 deletions(-) diff --git a/src/ALE/coord_hycom.F90 b/src/ALE/coord_hycom.F90 index bfcff9005c..bc25377dbe 100644 --- a/src/ALE/coord_hycom.F90 +++ b/src/ALE/coord_hycom.F90 @@ -133,7 +133,7 @@ subroutine build_hycom1_column(CS, US, eqn_of_state, nz, depth, h, T, S, p_col, z_scale = 1.0 ; if (present(zScale)) z_scale = zScale ! Work bottom recording potential density - call calculate_density(T, S, p_col, rho_col, 1, nz, eqn_of_state, US=US) + call calculate_density(T, S, p_col, rho_col, eqn_of_state, US=US) ! This ensures the potential density profile is monotonic ! although not necessarily single valued. do k = nz-1, 1, -1 diff --git a/src/ALE/coord_rho.F90 b/src/ALE/coord_rho.F90 index 565656ecb0..7c6a00e714 100644 --- a/src/ALE/coord_rho.F90 +++ b/src/ALE/coord_rho.F90 @@ -126,7 +126,7 @@ subroutine build_rho_column(CS, US, nz, depth, h, T, S, eqn_of_state, z_interfac ! Compute densities on source column pres(:) = CS%ref_pressure - call calculate_density(T, S, pres, densities, 1, nz, eqn_of_state, US=US) + call calculate_density(T, S, pres, densities, eqn_of_state, US=US) do k = 1,count_nonzero_layers densities(k) = densities(mapping(k)) enddo diff --git a/src/ALE/coord_slight.F90 b/src/ALE/coord_slight.F90 index 000315bae8..de21e7027e 100644 --- a/src/ALE/coord_slight.F90 +++ b/src/ALE/coord_slight.F90 @@ -253,7 +253,7 @@ subroutine build_slight_column(CS, US, eqn_of_state, H_to_pres, H_subroundoff, & dz = (z_col(nz+1) - z_col(1)) / real(nz) do K=2,nz ; z_col_new(K) = z_col(1) + dz*real(K-1) ; enddo else - call calculate_density(T_col, S_col, p_col, rho_col, 1, nz, eqn_of_state, US=US) + call calculate_density(T_col, S_col, p_col, rho_col, eqn_of_state, US=US) ! Find the locations of the target potential densities, flagging ! locations in apparently unstable regions as not reliable. @@ -374,10 +374,10 @@ subroutine build_slight_column(CS, US, eqn_of_state, H_to_pres, H_subroundoff, & enddo T_int(nz+1) = T_f(nz) ; S_int(nz+1) = S_f(nz) p_IS(nz+1) = z_col(nz+1) * H_to_pres - call calculate_density_derivs(T_int, S_int, p_IS, drhoIS_dT, drhoIS_dS, 2, nz-1, & - eqn_of_state, US) - call calculate_density_derivs(T_int, S_int, p_R, drhoR_dT, drhoR_dS, 2, nz-1, & - eqn_of_state, US) + call calculate_density_derivs(T_int, S_int, p_IS, drhoIS_dT, drhoIS_dS, & + eqn_of_state, US, dom=(/2,nz/)) + call calculate_density_derivs(T_int, S_int, p_R, drhoR_dT, drhoR_dS, & + eqn_of_state, US, dom=(/2,nz/)) if (CS%compressibility_fraction > 0.0) then call calculate_compress(T_int, S_int, p_R(:), rho_tmp, drho_dp, 2, nz-1, eqn_of_state, US) else diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index efd4a80a52..4ca4682ef4 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -74,7 +74,7 @@ module MOM use MOM_dynamics_unsplit_RK2, only : initialize_dyn_unsplit_RK2, end_dyn_unsplit_RK2 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, calculate_TFreeze +use MOM_EOS, only : EOS_init, calculate_density, calculate_TFreeze, EOS_domain use MOM_fixed_initialization, only : MOM_initialize_fixed use MOM_forcing_type, only : allocate_forcing_type, allocate_mech_forcing use MOM_forcing_type, only : deallocate_mech_forcing, deallocate_forcing_type @@ -2904,8 +2904,8 @@ subroutine adjust_ssh_for_p_atm(tv, G, GV, US, ssh, p_atm, use_EOS) ! Correct the output sea surface height for the contribution from the ice pressure. do j=js,je if (calc_rho) then - call calculate_density(tv%T(:,j,1), tv%S(:,j,1), 0.5*p_atm(:,j), Rho_conv, G%HI, & - tv%eqn_of_state, US) + call calculate_density(tv%T(:,j,1), tv%S(:,j,1), 0.5*p_atm(:,j), Rho_conv, & + tv%eqn_of_state, US, dom=EOS_domain(G%HI)) do i=is,ie IgR0 = US%Z_to_m / (Rho_conv(i) * GV%g_Earth) ssh(i,j) = ssh(i,j) + p_atm(i,j) * IgR0 diff --git a/src/core/MOM_forcing_type.F90 b/src/core/MOM_forcing_type.F90 index 12f165372b..c54b26a6ab 100644 --- a/src/core/MOM_forcing_type.F90 +++ b/src/core/MOM_forcing_type.F90 @@ -10,7 +10,7 @@ module MOM_forcing_type use MOM_diag_mediator, only : time_type, diag_ctrl, safe_alloc_alloc, query_averaging_enabled use MOM_diag_mediator, only : enable_averages, enable_averaging, disable_averaging use MOM_error_handler, only : MOM_error, FATAL, WARNING -use MOM_EOS, only : calculate_density_derivs +use MOM_EOS, only : calculate_density_derivs, EOS_domain use MOM_file_parser, only : get_param, log_param, log_version, param_file_type use MOM_grid, only : ocean_grid_type use MOM_opacity, only : sumSWoverBands, optics_type, extract_optics_slice, optics_nbands @@ -953,8 +953,8 @@ subroutine calculateBuoyancyFlux1d(G, GV, US, fluxes, optics, nsw, h, Temp, Salt H_limit_fluxes, .true., penSWbnd, netPen) ! Density derivatives - call calculate_density_derivs(Temp(:,j,1), Salt(:,j,1), pressure, dRhodT, dRhodS, G%HI, & - tv%eqn_of_state, US) + call calculate_density_derivs(Temp(:,j,1), Salt(:,j,1), pressure, dRhodT, dRhodS, & + tv%eqn_of_state, US, dom=EOS_domain(G%HI)) ! Adjust netSalt to reflect dilution effect of FW flux netSalt(G%isc:G%iec) = netSalt(G%isc:G%iec) - Salt(G%isc:G%iec,j,1) * netH(G%isc:G%iec) ! ppt H/s diff --git a/src/diagnostics/MOM_diagnostics.F90 b/src/diagnostics/MOM_diagnostics.F90 index 94f6acc9c3..8d4c5dfa9b 100644 --- a/src/diagnostics/MOM_diagnostics.F90 +++ b/src/diagnostics/MOM_diagnostics.F90 @@ -15,7 +15,7 @@ module MOM_diagnostics use MOM_diag_mediator, only : diag_save_grids, diag_restore_grids, diag_copy_storage_to_diag use MOM_domains, only : create_group_pass, do_group_pass, group_pass_type use MOM_domains, only : To_North, To_East -use MOM_EOS, only : calculate_density, int_density_dz +use MOM_EOS, only : calculate_density, int_density_dz, EOS_domain 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 @@ -359,8 +359,8 @@ subroutine calculate_diagnostic_fields(u, v, h, uh, vh, tv, ADp, CDp, p_surf, & pressure_1d(i) = pressure_1d(i) + 0.5*(GV%H_to_RZ*GV%g_Earth)*h(i,j,k) enddo ! Store in-situ density [R ~> kg m-3] in work_3d - call calculate_density(tv%T(:,j,k), tv%S(:,j,k), pressure_1d, rho_in_situ, G%HI, & - tv%eqn_of_state, US) + call calculate_density(tv%T(:,j,k), tv%S(:,j,k), pressure_1d, rho_in_situ, & + tv%eqn_of_state, US, dom=EOS_domain(G%HI)) do i=is,ie ! Cell thickness = dz = dp/(g*rho) (meter); store in work_3d work_3d(i,j,k) = (GV%H_to_RZ*h(i,j,k)) / rho_in_situ(i) enddo @@ -465,8 +465,8 @@ subroutine calculate_diagnostic_fields(u, v, h, uh, vh, tv, ADp, CDp, p_surf, & pressure_1d(:) = tv%P_Ref !$OMP parallel do default(shared) do k=1,nz ; do j=js-1,je+1 - call calculate_density(tv%T(:,j,k), tv%S(:,j,k), pressure_1d, Rcv(:,j,k), G%HI, & - tv%eqn_of_state, US, halo=1) + call calculate_density(tv%T(:,j,k), tv%S(:,j,k), pressure_1d, Rcv(:,j,k), tv%eqn_of_state, & + US, dom=EOS_domain(G%HI, halo=1)) enddo ; enddo else ! Rcv should not be used much in this case, so fill in sensible values. do k=1,nz ; do j=js-1,je+1 ; do i=is-1,ie+1 @@ -588,7 +588,8 @@ subroutine calculate_diagnostic_fields(u, v, h, uh, vh, tv, ADp, CDp, p_surf, & pressure_1d(:) = 0. !$OMP parallel do default(shared) do k=1,nz ; do j=js,je - call calculate_density(tv%T(:,j,k), tv%S(:,j,k), pressure_1d, Rcv(:,j,k), G%HI, tv%eqn_of_state, US) + call calculate_density(tv%T(:,j,k), tv%S(:,j,k), pressure_1d, Rcv(:,j,k), & + tv%eqn_of_state, US, dom=EOS_domain(G%HI)) enddo ; enddo if (CS%id_rhopot0 > 0) call post_data(CS%id_rhopot0, Rcv, CS%diag) endif @@ -596,7 +597,8 @@ subroutine calculate_diagnostic_fields(u, v, h, uh, vh, tv, ADp, CDp, p_surf, & pressure_1d(:) = 2.0e7*US%kg_m3_to_R*US%m_s_to_L_T**2 ! 2000 dbars !$OMP parallel do default(shared) do k=1,nz ; do j=js,je - call calculate_density(tv%T(:,j,k), tv%S(:,j,k), pressure_1d, Rcv(:,j,k), G%HI, tv%eqn_of_state, US) + call calculate_density(tv%T(:,j,k), tv%S(:,j,k), pressure_1d, Rcv(:,j,k), & + tv%eqn_of_state, US, dom=EOS_domain(G%HI)) enddo ; enddo if (CS%id_rhopot2 > 0) call post_data(CS%id_rhopot2, Rcv, CS%diag) endif @@ -606,7 +608,8 @@ subroutine calculate_diagnostic_fields(u, v, h, uh, vh, tv, ADp, CDp, p_surf, & pressure_1d(:) = 0. ! Start at p=0 Pa at surface do k=1,nz pressure_1d(:) = pressure_1d(:) + 0.5 * h(:,j,k) * (GV%H_to_RZ*GV%g_Earth) ! Pressure in middle of layer k - call calculate_density(tv%T(:,j,k), tv%S(:,j,k), pressure_1d, Rcv(:,j,k), G%HI, tv%eqn_of_state, US) + call calculate_density(tv%T(:,j,k), tv%S(:,j,k), pressure_1d, Rcv(:,j,k), & + tv%eqn_of_state, US, dom=EOS_domain(G%HI)) pressure_1d(:) = pressure_1d(:) + 0.5 * h(:,j,k) * (GV%H_to_RZ*GV%g_Earth) ! Pressure at bottom of layer k enddo enddo diff --git a/src/equation_of_state/MOM_EOS.F90 b/src/equation_of_state/MOM_EOS.F90 index 9788c84338..b57677d8fa 100644 --- a/src/equation_of_state/MOM_EOS.F90 +++ b/src/equation_of_state/MOM_EOS.F90 @@ -40,7 +40,7 @@ module MOM_EOS public calculate_compress, calculate_density, query_compressible 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_init, EOS_manual_init, EOS_end, EOS_allocate, EOS_domain 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 @@ -59,23 +59,24 @@ module MOM_EOS !> Calculates density of sea water from T, S and P interface calculate_density - module procedure calculate_density_scalar, calculate_density_array, calculate_density_HI_1d + module procedure calculate_density_scalar, calculate_density_array, calculate_density_1d end interface calculate_density !> Calculates specific volume of sea water from T, S and P interface calculate_spec_vol - module procedure calc_spec_vol_scalar, calculate_spec_vol_array, calc_spec_vol_HI_1d, calc_spec_vol_US + module procedure calc_spec_vol_scalar, calculate_spec_vol_array, & + calc_spec_vol_1d end interface calculate_spec_vol !> Calculate the derivatives of density with temperature and salinity from T, S, and P interface calculate_density_derivs module procedure calculate_density_derivs_scalar, calculate_density_derivs_array, & - calculate_density_derivs_HI_1d + calculate_density_derivs_1d end interface calculate_density_derivs !> Calculate the derivatives of specific volume with temperature and salinity from T, S, and P interface calculate_specific_vol_derivs - module procedure calculate_spec_vol_derivs_array, calc_spec_vol_derivs_US, calc_spec_vol_derivs_HI_1d + module procedure calculate_spec_vol_derivs_array, calc_spec_vol_derivs_1d end interface calculate_specific_vol_derivs !> Calculates the second derivatives of density with various combinations of temperature, @@ -255,44 +256,64 @@ subroutine calculate_density_array(T, S, pressure, rho, start, npts, EOS, rho_re end subroutine calculate_density_array -!> Calls the appropriate subroutine to calculate the density of sea water for 1-D array inputs -!! using array extents determined from a hor_index_type. +!> Calls the appropriate subroutine to calculate the density of sea water for 1-D array inputs, +!! potentially limiting the domain of indices that are worked on. !! If rho_ref is present, the anomaly with respect to rho_ref is returned. -subroutine calculate_density_HI_1d(T, S, pressure, rho, HI, EOS, US, halo) - type(hor_index_type), intent(in) :: HI !< The horizontal index structure - real, dimension(HI%isd:HI%ied), intent(in) :: T !< Potential temperature referenced to the surface [degC] - real, dimension(HI%isd:HI%ied), intent(in) :: S !< Salinity [ppt] - real, dimension(HI%isd:HI%ied), intent(in) :: pressure !< Pressure [R L2 T-2 ~> Pa] - real, dimension(HI%isd:HI%ied), intent(inout) :: rho !< Density (in-situ if pressure is local) [R ~> kg m-3] - type(EOS_type), pointer :: EOS !< Equation of state structure - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - integer, optional, intent(in) :: halo !< The halo size to work on; missing is equivalent to 0. +subroutine calculate_density_1d(T, S, pressure, rho, EOS, US, dom, rho_ref, scale) + real, dimension(:), intent(in) :: T !< Potential temperature referenced to the surface [degC] + real, dimension(:), intent(in) :: S !< Salinity [ppt] + real, dimension(:), intent(in) :: pressure !< Pressure [R L2 T-2 ~> Pa] + real, dimension(:), intent(inout) :: rho !< Density (in-situ if pressure is local) [R ~> kg m-3] + type(EOS_type), pointer :: EOS !< Equation of state structure + type(unit_scale_type), optional, intent(in) :: US !< A dimensional unit scaling type + integer, dimension(2), optional, intent(in) :: dom !< The domain of indices to work on, taking + !! into account that arrays start at 1. + real, optional, intent(in) :: rho_ref !< A reference density [kg m-3] + real, optional, intent(in) :: scale !< A multiplicative factor by which to scale density + !! in combination with scaling given by US [various] ! Local variables - real, dimension(HI%isd:HI%ied) :: pres ! Pressure converted to [Pa] - integer :: i, is, ie, start, npts, halo_sz + real :: p_scale ! A factor to convert pressure to units of Pa [Pa T2 R-1 L-2 ~> 1] + real :: rho_scale ! A factor to convert density from kg m-3 to the desired units [R m3 kg-1 ~> 1] + real :: rho_unscale ! A factor to convert density from R to kg m-3 [kg m-3 R-1 ~> 1] + real :: rho_reference ! rho_ref converted to [kg m-3] + real, dimension(size(rho)) :: pres ! Pressure converted to [Pa] + integer :: i, is, ie, npts if (.not.associated(EOS)) call MOM_error(FATAL, & - "calculate_density_HI_1d called with an unassociated EOS_type EOS.") + "calculate_density_1d called with an unassociated EOS_type EOS.") - halo_sz = 0 ; if (present(halo)) halo_sz = halo + if (present(dom)) then + is = dom(1) ; ie = dom(2) ; npts = 1 + ie - is + else + is = 1 ; ie = size(rho) ; npts = 1 + ie - is + endif - start = HI%isc - (HI%isd-1) - halo_sz - npts = HI%iec - HI%isc + 1 + 2*halo_sz - is = HI%isc - halo_sz ; ie = HI%iec + halo_sz + p_scale = 1.0 ; if (present(US)) p_scale = US%RL2_T2_to_Pa + rho_unscale = 1.0 ; if (present(US)) rho_unscale = US%R_to_kg_m3 + + if ((p_scale == 1.0) .and. (rho_unscale == 1.0)) then + call calculate_density_array(T, S, pressure, rho, is, npts, EOS, rho_ref=rho_ref) + elseif (present(rho_ref)) then ! This is the same as above, but with some extra work to rescale variables. + do i=is,ie ; pres(i) = p_scale * pressure(i) ; enddo + rho_reference = rho_unscale*rho_ref + call calculate_density_array(T, S, pres, rho, is, npts, EOS, rho_ref=rho_reference) + else ! There is rescaling of variables, but rho_ref is not present. Passing a 0 value of rho_ref + ! changes answers at roundoff for some equations of state, like Wright and UNESCO. + do i=is,ie ; pres(i) = p_scale * pressure(i) ; enddo + call calculate_density_array(T, S, pres, rho, is, npts, EOS) + endif - if (US%RL2_T2_to_Pa == 1.0) then - call calculate_density_array(T, S, pressure, rho, start, npts, EOS) - else ! There is rescaling of variables, including pressure. - do i=is,ie ; pres(i) = US%RL2_T2_to_Pa * pressure(i) ; enddo - call calculate_density_array(T, S, pres, rho, start, npts, EOS) + if (present(US) .or. present(scale)) then + rho_scale = 1.0 ; if (present(US)) rho_scale = US%kg_m3_to_R + if (present(scale)) rho_scale = rho_scale * scale + if (rho_scale /= 1.0) then ; do i=is,ie + rho(i) = rho_scale * rho(i) + enddo ; endif endif - if (US%kg_m3_to_R /= 1.0) then ; do i=is,ie - rho(i) = US%kg_m3_to_R * rho(i) - enddo ; endif +end subroutine calculate_density_1d -end subroutine calculate_density_HI_1d !> Calls the appropriate subroutine to calculate the specific volume of sea water !! for 1-D array inputs. @@ -380,97 +401,64 @@ subroutine calc_spec_vol_scalar(T, S, pressure, specvol, EOS, spv_ref, US, scale end subroutine calc_spec_vol_scalar -!> Calls the appropriate subroutine to calculate the specific volume of sea water -!! for 1-D array inputs with dimensional rescaling. -subroutine calc_spec_vol_US(T, S, pressure, specvol, start, npts, EOS, US, spv_ref, scale) - real, dimension(:), intent(in) :: T !< potential temperature relative to the surface [degC] - real, dimension(:), intent(in) :: S !< salinity [ppt] - real, dimension(:), intent(in) :: pressure !< pressure [Pa] or [R L2 T-2 ~> Pa] - real, dimension(:), intent(inout) :: specvol !< in situ specific volume [kg m-3] or [R-1 ~> m3 kg-1] - 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 - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - real, optional, intent(in) :: spv_ref !< A reference specific volume [m3 kg-1] - real, optional, intent(in) :: scale !< A multiplicative factor by which to scale specific - !! volume in combination with scaling given by US [various] - - ! Local variables - real, dimension(size(pressure)) :: pres ! Pressure converted to [Pa] - real :: spv_reference ! spv_ref converted to [m3 kg-1] - real :: spv_scale ! A factor to convert specific volume from m3 kg-1 to the desired units [kg R-1 m-3 ~> 1] - integer :: i, is, ie - - if (.not.associated(EOS)) call MOM_error(FATAL, & - "calculate_spec_vol_array called with an unassociated EOS_type EOS.") - - is = start ; ie = is + npts - 1 - - if ((US%RL2_T2_to_Pa == 1.0) .and. (US%R_to_kg_m3 == 1.0)) then - call calculate_spec_vol_array(T, S, pressure, specvol, start, npts, EOS, spv_ref) - elseif (present(spv_ref)) then ! This is the same as above, but with some extra work to rescale variables. - do i=is,ie ; pres(i) = US%RL2_T2_to_Pa * pressure(i) ; enddo - spv_reference = US%kg_m3_to_R*spv_ref - call calculate_spec_vol_array(T, S, pres, specvol, start, npts, EOS, spv_reference) - else ! There is rescaling of variables, but spv_ref is not present. Passing a 0 value of spv_ref - ! changes answers at roundoff for some equations of state, like Wright and UNESCO. - do i=is,ie ; pres(i) = US%RL2_T2_to_Pa * pressure(i) ; enddo - call calculate_spec_vol_array(T, S, pres, specvol, start, npts, EOS) - endif - - spv_scale = US%R_to_kg_m3 - if (present(scale)) spv_scale = spv_scale * scale - if (spv_scale /= 1.0) then ; do i=is,ie - specvol(i) = spv_scale * specvol(i) - enddo ; endif - -end subroutine calc_spec_vol_US - - !> Calls the appropriate subroutine to calculate the specific volume of sea water for 1-D array -!! inputs using array extents determined from a hor_index_type. -subroutine calc_spec_vol_HI_1d(T, S, pressure, specvol, HI, EOS, US, halo, spv_ref) - type(hor_index_type), intent(in) :: HI !< The horizontal index structure - real, dimension(HI%isd:HI%ied), intent(in) :: T !< Potential temperature referenced to the surface [degC] - real, dimension(HI%isd:HI%ied), intent(in) :: S !< Salinity [ppt] - real, dimension(HI%isd:HI%ied), intent(in) :: pressure !< Pressure [R L2 T-2 ~> Pa] - real, dimension(HI%isd:HI%ied), intent(inout) :: specvol !< In situ specific volume [R-1 ~> m3 kg-1] - type(EOS_type), pointer :: EOS !< Equation of state structure - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - integer, optional, intent(in) :: halo !< The halo size to work on; missing is equivalent to 0. - real, optional, intent(in) :: spv_ref !< A reference specific volume [R-1 ~> m3 kg-1] +!! inputs, potentially limiting the domain of indices that are worked on. +subroutine calc_spec_vol_1d(T, S, pressure, specvol, EOS, US, dom, spv_ref, scale) + real, dimension(:), intent(in) :: T !< Potential temperature referenced to the surface [degC] + real, dimension(:), intent(in) :: S !< Salinity [ppt] + real, dimension(:), intent(in) :: pressure !< Pressure [R L2 T-2 ~> Pa] + real, dimension(:), intent(inout) :: specvol !< In situ specific volume [R-1 ~> m3 kg-1] + type(EOS_type), pointer :: EOS !< Equation of state structure + type(unit_scale_type), optional, intent(in) :: US !< A dimensional unit scaling type + integer, dimension(2), optional, intent(in) :: dom !< The domain of indices to work on, taking + !! into account that arrays start at 1. + real, optional, intent(in) :: spv_ref !< A reference specific volume [R-1 ~> m3 kg-1] + real, optional, intent(in) :: scale !< A multiplicative factor by which to scale + !! output specific volume in combination with + !! scaling given by US [various] ! Local variables - real, dimension(HI%isd:HI%ied) :: pres ! Pressure converted to [Pa] + real, dimension(size(specvol)) :: pres ! Pressure converted to [Pa] + real :: p_scale ! A factor to convert pressure to units of Pa [Pa T2 R-1 L-2 ~> 1] + real :: spv_unscale ! A factor to convert specific volume from R-1 to m3 kg-1 [m3 kg-1 R ~> 1] + real :: spv_scale ! A factor to convert specific volume from m3 kg-1 to the desired units [kg m-3 R-1 ~> 1] real :: spv_reference ! spv_ref converted to [m3 kg-1] - integer :: i, is, ie, start, npts, halo_sz + integer :: i, is, ie, npts if (.not.associated(EOS)) call MOM_error(FATAL, & - "calc_spec_vol_HI_1d called with an unassociated EOS_type EOS.") + "calc_spec_vol_1d called with an unassociated EOS_type EOS.") - halo_sz = 0 ; if (present(halo)) halo_sz = halo + if (present(dom)) then + is = dom(1) ; ie = dom(2) ; npts = 1 + ie - is + else + is = 1 ; ie = size(specvol) ; npts = 1 + ie - is + endif - start = HI%isc - (HI%isd-1) - halo_sz - npts = HI%iec - HI%isc + 1 + 2*halo_sz - is = HI%isc - halo_sz ; ie = HI%iec + halo_sz + p_scale = 1.0 ; if (present(US)) p_scale = US%RL2_T2_to_Pa + spv_unscale = 1.0 ; if (present(US)) spv_unscale = US%kg_m3_to_R - if ((US%RL2_T2_to_Pa == 1.0) .and. (US%R_to_kg_m3 == 1.0)) then - call calculate_spec_vol_array(T, S, pressure, specvol, start, npts, EOS, spv_ref) + if ((p_scale == 1.0) .and. (spv_unscale == 1.0)) then + call calculate_spec_vol_array(T, S, pressure, specvol, is, npts, EOS, spv_ref) elseif (present(spv_ref)) then ! This is the same as above, but with some extra work to rescale variables. - do i=is,ie ; pres(i) = US%RL2_T2_to_Pa * pressure(i) ; enddo - spv_reference = US%kg_m3_to_R*spv_ref - call calculate_spec_vol_array(T, S, pres, specvol, start, npts, EOS, spv_reference) + do i=is,ie ; pres(i) = p_scale * pressure(i) ; enddo + spv_reference = spv_unscale*spv_ref + call calculate_spec_vol_array(T, S, pres, specvol, is, npts, EOS, spv_reference) else ! There is rescaling of variables, but spv_ref is not present. Passing a 0 value of spv_ref ! changes answers at roundoff for some equations of state, like Wright and UNESCO. - do i=is,ie ; pres(i) = US%RL2_T2_to_Pa * pressure(i) ; enddo - call calculate_spec_vol_array(T, S, pres, specvol, start, npts, EOS) + do i=is,ie ; pres(i) = p_scale * pressure(i) ; enddo + call calculate_spec_vol_array(T, S, pres, specvol, is, npts, EOS) endif - if (US%R_to_kg_m3 /= 1.0) then ; do i=is,ie - specvol(i) = US%R_to_kg_m3 * specvol(i) - enddo ; endif + if (present(US) .or. present(scale)) then + spv_scale = 1.0 ; if (present(US)) spv_scale = US%R_to_kg_m3 + if (present(scale)) spv_scale = spv_scale * scale + if (spv_scale /= 1.0) then ; do i=is,ie + specvol(i) = spv_scale * specvol(i) + enddo ; endif + endif + +end subroutine calc_spec_vol_1d -end subroutine calc_spec_vol_HI_1d !> Calls the appropriate subroutine to calculate the freezing point for scalar inputs. subroutine calculate_TFreeze_scalar(S, pressure, T_fr, EOS, pres_scale) @@ -626,45 +614,55 @@ end subroutine calculate_density_derivs_array !> Calls the appropriate subroutine to calculate density derivatives for 1-D array inputs. -subroutine calculate_density_derivs_HI_1d(T, S, pressure, drho_dT, drho_dS, HI, EOS, US, halo) - type(hor_index_type), intent(in) :: HI !< The horizontal index structure - real, dimension(HI%isd:HI%ied), intent(in) :: T !< Potential temperature referenced to the surface [degC] - real, dimension(HI%isd:HI%ied), intent(in) :: S !< Salinity [ppt] - real, dimension(HI%isd:HI%ied), intent(in) :: pressure !< Pressure [R L2 T-2 ~> Pa] - real, dimension(HI%isd:HI%ied), intent(inout) :: drho_dT !< The partial derivative of density with potential - !! temperature [R degC-1 ~> kg m-3 degC-1] - real, dimension(HI%isd:HI%ied), intent(inout) :: drho_dS !< The partial derivative of density with salinity - !! [R degC-1 ~> kg m-3 ppt-1] - type(EOS_type), pointer :: EOS !< Equation of state structure - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - integer, optional, intent(in) :: halo !< The halo size to work on; missing is equivalent to 0. +subroutine calculate_density_derivs_1d(T, S, pressure, drho_dT, drho_dS, EOS, US, dom, scale) + real, dimension(:), intent(in) :: T !< Potential temperature referenced to the surface [degC] + real, dimension(:), intent(in) :: S !< Salinity [ppt] + real, dimension(:), intent(in) :: pressure !< Pressure [R L2 T-2 ~> Pa] + real, dimension(:), intent(inout) :: drho_dT !< The partial derivative of density with potential + !! temperature [R degC-1 ~> kg m-3 degC-1] + real, dimension(:), intent(inout) :: drho_dS !< The partial derivative of density with salinity + !! [R degC-1 ~> kg m-3 ppt-1] + type(EOS_type), pointer :: EOS !< Equation of state structure + type(unit_scale_type), optional, intent(in) :: US !< A dimensional unit scaling type + integer, dimension(2), optional, intent(in) :: dom !< The domain of indices to work on, taking + !! into account that arrays start at 1. + real, optional, intent(in) :: scale !< A multiplicative factor by which to scale density + !! in combination with scaling given by US [various] ! Local variables - real, dimension(HI%isd:HI%ied) :: pres ! Pressure converted to [Pa] - integer :: i, is, ie, start, npts, halo_sz + real, dimension(size(drho_dT)) :: pres ! Pressure converted to [Pa] + real :: rho_scale ! A factor to convert density from kg m-3 to the desired units [R m3 kg-1 ~> 1] + real :: p_scale ! A factor to convert pressure to units of Pa [Pa T2 R-1 L-2 ~> 1] + integer :: i, is, ie, npts if (.not.associated(EOS)) call MOM_error(FATAL, & "calculate_density_derivs called with an unassociated EOS_type EOS.") - halo_sz = 0 ; if (present(halo)) halo_sz = halo + if (present(dom)) then + is = dom(1) ; ie = dom(2) ; npts = 1 + ie - is + else + is = 1 ; ie = size(drho_dT) ; npts = 1 + ie - is + endif - start = HI%isc - (HI%isd-1) - halo_sz - npts = HI%iec - HI%isc + 1 + 2*halo_sz - is = HI%isc - halo_sz ; ie = HI%iec + halo_sz + p_scale = 1.0 ; if (present(US)) p_scale = US%RL2_T2_to_Pa - if (US%RL2_T2_to_Pa == 1.0) then - call calculate_density_derivs_array(T, S, pressure, drho_dT, drho_dS, start, npts, EOS) + if (p_scale == 1.0) then + call calculate_density_derivs_array(T, S, pressure, drho_dT, drho_dS, is, npts, EOS) else - do i=is,ie ; pres(i) = US%RL2_T2_to_Pa * pressure(i) ; enddo - call calculate_density_derivs_array(T, S, pres, drho_dT, drho_dS, start, npts, EOS) + do i=is,ie ; pres(i) = p_scale * pressure(i) ; enddo + call calculate_density_derivs_array(T, S, pres, drho_dT, drho_dS, is, npts, EOS) endif - if (US%kg_m3_to_R /= 1.0) then ; do i=is,ie - drho_dT(i) = US%kg_m3_to_R * drho_dT(i) - drho_dS(i) = US%kg_m3_to_R * drho_dS(i) - enddo ; endif + if (present(US) .or. present(scale)) then + rho_scale = 1.0 ; if (present(US)) rho_scale = US%kg_m3_to_R + if (present(scale)) rho_scale = rho_scale * scale + if (rho_scale /= 1.0) then ; do i=is,ie + drho_dT(i) = rho_scale * drho_dT(i) + drho_dS(i) = rho_scale * drho_dS(i) + enddo ; endif + endif -end subroutine calculate_density_derivs_HI_1d +end subroutine calculate_density_derivs_1d !> Calls the appropriate subroutines to calculate density derivatives by promoting a scalar @@ -912,90 +910,56 @@ subroutine calculate_spec_vol_derivs_array(T, S, pressure, dSV_dT, dSV_dS, start end subroutine calculate_spec_vol_derivs_array - -!> Calls the appropriate subroutine to calculate specific volume derivatives for an array with unit scaling. -subroutine calc_spec_vol_derivs_US(T, S, pressure, dSV_dT, dSV_dS, start, npts, EOS, US, scale) - real, dimension(:), intent(in) :: T !< Potential temperature referenced to the surface [degC] - real, dimension(:), intent(in) :: S !< Salinity [ppt] - real, dimension(:), intent(in) :: pressure !< Pressure [R L2 T-2 ~> Pa] - real, dimension(:), intent(inout) :: dSV_dT !< The partial derivative of specific volume with potential - !! temperature [R-1 degC-1 ~> m3 kg-1 degC-1] - real, dimension(:), intent(inout) :: dSV_dS !< The partial derivative of specific volume with salinity - !! [R-1 ppt-1 ~> m3 kg-1 ppt-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 - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - real, optional, intent(in) :: scale !< A multiplicative factor by which to scale specific - !! volume in combination with scaling given by US [various] +!> Calls the appropriate subroutine to calculate specific volume derivatives for 1-d array inputs, +!! potentially limiting the domain of indices that are worked on. +subroutine calc_spec_vol_derivs_1d(T, S, pressure, dSV_dT, dSV_dS, EOS, US, dom, scale) + real, dimension(:), intent(in) :: T !< Potential temperature referenced to the surface [degC] + real, dimension(:), intent(in) :: S !< Salinity [ppt] + real, dimension(:), intent(in) :: pressure !< Pressure [R L2 T-2 ~> Pa] + real, dimension(:), intent(inout) :: dSV_dT !< The partial derivative of specific volume with potential + !! temperature [R-1 degC-1 ~> m3 kg-1 degC-1] + real, dimension(:), intent(inout) :: dSV_dS !< The partial derivative of specific volume with salinity + !! [R-1 ppt-1 ~> m3 kg-1 ppt-1] + type(EOS_type), pointer :: EOS !< Equation of state structure + type(unit_scale_type), optional, intent(in) :: US !< A dimensional unit scaling type + integer, dimension(2), optional, intent(in) :: dom !< The domain of indices to work on, taking + !! into account that arrays start at 1. + real, optional, intent(in) :: scale !< A multiplicative factor by which to scale specific + !! volume in combination with scaling given by US [various] ! Local variables - real, dimension(size(T)) :: press ! Pressure converted to [Pa] + real, dimension(size(dSV_dT)) :: press ! Pressure converted to [Pa] real :: spv_scale ! A factor to convert specific volume from m3 kg-1 to the desired units [kg R-1 m-3 ~> 1] - integer :: i, is, ie + real :: p_scale ! A factor to convert pressure to units of Pa [Pa T2 R-1 L-2 ~> 1] + integer :: i, is, ie, npts if (.not.associated(EOS)) call MOM_error(FATAL, & - "calculate_spec_vol_derivs_array called with an unassociated EOS_type EOS.") - - is = start ; ie = is + npts - 1 + "calculate_spec_vol_derivs_1d called with an unassociated EOS_type EOS.") - if (US%RL2_T2_to_Pa == 1.0) then - call calculate_spec_vol_derivs_array(T, S, pressure, dSV_dT, dSV_dS, start, npts, EOS) + if (present(dom)) then + is = dom(1) ; ie = dom(2) ; npts = 1 + ie - is else - do i=is,ie ; press(i) = US%RL2_T2_to_Pa * pressure(i) ; enddo - call calculate_spec_vol_derivs_array(T, S, press, dSV_dT, dSV_dS, start, npts, EOS) + is = 1 ; ie = size(dSV_dT) ; npts = 1 + ie - is endif + p_scale = 1.0 ; if (present(US)) p_scale = US%RL2_T2_to_Pa - spv_scale = US%R_to_kg_m3 - if (present(scale)) spv_scale = spv_scale * scale - if (spv_scale /= 1.0) then ; do i=is,ie - dSV_dT(i) = spv_scale * dSV_dT(i) - dSV_dS(i) = spv_scale * dSV_dS(i) - enddo ; endif - -end subroutine calc_spec_vol_derivs_US - -!> Calls the appropriate subroutine to calculate specific volume derivatives for array inputs -!! using array extents determined from a hor_index_type.. -subroutine calc_spec_vol_derivs_HI_1d(T, S, pressure, dSV_dT, dSV_dS, HI, EOS, US, halo) - type(hor_index_type), intent(in) :: HI !< The horizontal index structure - real, dimension(HI%isd:HI%ied), intent(in) :: T !< Potential temperature referenced to the surface [degC] - real, dimension(HI%isd:HI%ied), intent(in) :: S !< Salinity [ppt] - real, dimension(HI%isd:HI%ied), intent(in) :: pressure !< Pressure [R L2 T-2 ~> Pa] - real, dimension(HI%isd:HI%ied), intent(inout) :: dSV_dT !< The partial derivative of specific volume with potential - !! temperature [R-1 degC-1 ~> m3 kg-1 degC-1] - real, dimension(HI%isd:HI%ied), intent(inout) :: dSV_dS !< The partial derivative of specific volume with salinity - !! [R-1 ppt-1 ~> m3 kg-1 ppt-1] - type(EOS_type), pointer :: EOS !< Equation of state structure - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - integer, optional, intent(in) :: halo !< The halo size to work on; missing is equivalent to 0. - - ! Local variables - real, dimension(HI%isd:HI%ied) :: press ! Pressure converted to [Pa] - integer :: i, is, ie, start, npts, halo_sz - - if (.not.associated(EOS)) call MOM_error(FATAL, & - "calculate_spec_vol_derivs_HI_1d called with an unassociated EOS_type EOS.") - - halo_sz = 0 ; if (present(halo)) halo_sz = halo - - start = HI%isc - (HI%isd-1) - halo_sz - npts = HI%iec - HI%isc + 1 + 2*halo_sz - is = HI%isc - halo_sz ; ie = HI%iec + halo_sz - - if (US%RL2_T2_to_Pa == 1.0) then - call calculate_spec_vol_derivs_array(T, S, pressure, dSV_dT, dSV_dS, start, npts, EOS) + if (p_scale == 1.0) then + call calculate_spec_vol_derivs_array(T, S, pressure, dSV_dT, dSV_dS, is, npts, EOS) else - do i=is,ie ; press(i) = US%RL2_T2_to_Pa * pressure(i) ; enddo - call calculate_spec_vol_derivs_array(T, S, press, dSV_dT, dSV_dS, start, npts, EOS) + do i=is,ie ; press(i) = p_scale * pressure(i) ; enddo + call calculate_spec_vol_derivs_array(T, S, press, dSV_dT, dSV_dS, is, npts, EOS) endif - if (US%R_to_kg_m3 /= 1.0) then ; do i=is,ie - dSV_dT(i) = US%R_to_kg_m3 * dSV_dT(i) - dSV_dS(i) = US%R_to_kg_m3 * dSV_dS(i) - enddo ; endif + if (present(US) .or. present(scale)) then + spv_scale = 1.0 ; if (present(US)) spv_scale = US%R_to_kg_m3 + if (present(scale)) spv_scale = spv_scale * scale + if (spv_scale /= 1.0) then ; do i=is,ie + dSV_dT(i) = spv_scale * dSV_dT(i) + dSV_dS(i) = spv_scale * dSV_dS(i) + enddo ; endif + endif -end subroutine calc_spec_vol_derivs_HI_1d +end subroutine calc_spec_vol_derivs_1d !> Calls the appropriate subroutine to calculate the density and compressibility for 1-D array @@ -1079,12 +1043,31 @@ subroutine calculate_compress_scalar(T, S, pressure, rho, drho_dp, EOS, US) end subroutine calculate_compress_scalar +!> This subroutine returns a two point integer array indicating the domain of i-indices +!! to work on in EOS calls based on information from a hor_index type +function EOS_domain(HI, halo) result(EOSdom) + type(hor_index_type), intent(in) :: HI !< The horizontal index structure + integer, optional, intent(in) :: halo !< The halo size to work on; missing is equivalent to 0. + integer, dimension(2) :: EOSdom !< The index domain that the EOS will work on, taking into account + !! that the arrays inside the EOS routines will start at 1. + + ! Local variables + integer :: halo_sz + + halo_sz = 0 ; if (present(halo)) halo_sz = halo + + EOSdom(1) = HI%isc - (HI%isd-1) - halo_sz + EOSdom(2) = HI%iec - (HI%isd-1) + halo_sz + +end function EOS_domain + + !> Calls the appropriate subroutine to calculate 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| < . +!! series for log(1-eps/1+eps) that assumes that |eps| < 0.34. subroutine int_specific_vol_dp(T, S, p_t, p_b, alpha_ref, HI, EOS, & dza, intp_dza, intx_dza, inty_dza, halo_size, & bathyP, dP_tiny, useMassWghtInterp, US) @@ -3039,7 +3022,7 @@ subroutine convert_temp_salt_for_TEOS10(T, S, HI, kd, mask_z, EOS) intent(in) :: mask_z !< 3d mask regulating which points to convert. type(EOS_type), pointer :: EOS !< Equation of state structure - integer :: i,j,k + integer :: i, j, k real :: gsw_sr_from_sp, gsw_ct_from_pt, gsw_sa_from_sp real :: p diff --git a/src/ice_shelf/MOM_ice_shelf.F90 b/src/ice_shelf/MOM_ice_shelf.F90 index 858af4e1ea..8f1587ab8b 100644 --- a/src/ice_shelf/MOM_ice_shelf.F90 +++ b/src/ice_shelf/MOM_ice_shelf.F90 @@ -35,7 +35,7 @@ module MOM_ice_shelf 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 : calculate_density, calculate_density_derivs, calculate_TFreeze, EOS_domain use MOM_EOS, only : EOS_type, EOS_init 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 @@ -375,10 +375,10 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) 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, Rhoml(:), G%HI, & - CS%eqn_of_state, US) - call calculate_density_derivs(state%sst(:,j), state%sss(:,j), p_int, dR0_dT, dR0_dS, G%HI, & - CS%eqn_of_state, US) + call calculate_density(state%sst(:,j), state%sss(:,j), p_int, Rhoml(:), & + CS%eqn_of_state, US, dom=EOS_domain(G%HI)) + call calculate_density_derivs(state%sst(:,j), state%sss(:,j), p_int, dR0_dT, dR0_dS, & + CS%eqn_of_state, US, dom=EOS_domain(G%HI)) do i=is,ie if ((state%ocean_mass(i,j) > US%RZ_to_kg_m2*CS%col_mass_melt_threshold) .and. & diff --git a/src/initialization/MOM_state_initialization.F90 b/src/initialization/MOM_state_initialization.F90 index 2efceb5991..2ac8ac47bf 100644 --- a/src/initialization/MOM_state_initialization.F90 +++ b/src/initialization/MOM_state_initialization.F90 @@ -41,7 +41,7 @@ module MOM_state_initialization use MOM_variables, only : thermo_var_ptrs use MOM_verticalGrid, only : setVerticalGridAxes, verticalGrid_type use MOM_ALE, only : pressure_gradient_plm -use MOM_EOS, only : calculate_density, calculate_density_derivs, EOS_type +use MOM_EOS, only : calculate_density, calculate_density_derivs, EOS_type, EOS_domain use MOM_EOS, only : int_specific_vol_dp, convert_temp_salt_for_TEOS10 use user_initialization, only : user_initialize_thickness, user_initialize_velocity use user_initialization, only : user_init_temperature_salinity @@ -959,8 +959,8 @@ subroutine convert_thickness(h, G, GV, US, tv) do k=1,nz do j=js,je do i=is,ie ; p_top(i,j) = p_bot(i,j) ; enddo - call calculate_density(tv%T(:,j,k), tv%S(:,j,k), p_top(:,j), rho, G%HI, & - tv%eqn_of_state, US) + call calculate_density(tv%T(:,j,k), tv%S(:,j,k), p_top(:,j), rho, & + tv%eqn_of_state, US, dom=EOS_domain(G%HI)) do i=is,ie p_bot(i,j) = p_top(i,j) + HR_to_pres * (h(i,j,k) * rho(i)) enddo @@ -970,8 +970,8 @@ subroutine convert_thickness(h, G, GV, US, tv) call int_specific_vol_dp(tv%T(:,:,k), tv%S(:,:,k), p_top, p_bot, 0.0, G%HI, & tv%eqn_of_state, dz_geo, US=US) if (itt < max_itt) then ; do j=js,je - call calculate_density(tv%T(:,j,k), tv%S(:,j,k), p_bot(:,j), rho, G%HI, & - tv%eqn_of_state, US) + call calculate_density(tv%T(:,j,k), tv%S(:,j,k), p_bot(:,j), rho, & + tv%eqn_of_state, US, dom=EOS_domain(G%HI)) ! Use Newton's method to correct the bottom value. ! The hydrostatic equation is sufficiently linear that no bounds-checking is needed. do i=is,ie @@ -1869,7 +1869,8 @@ subroutine initialize_sponges_file(G, GV, US, use_temperature, tv, param_file, C call MOM_read_data(filename, salin_var, tmp2(:,:,:), G%Domain) do j=js,je - call calculate_density(tmp(:,j,1), tmp2(:,j,1), pres, tmp_2d(:,j), G%HI, tv%eqn_of_state, US) + call calculate_density(tmp(:,j,1), tmp2(:,j,1), pres, tmp_2d(:,j), tv%eqn_of_state, US, & + dom=EOS_domain(G%HI)) enddo call set_up_sponge_ML_density(tmp_2d, G, CSp) @@ -2188,7 +2189,8 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, G, GV, US, PF, just_read_param press(:) = tv%P_Ref do k=1,kd ; do j=js,je - call calculate_density(temp_z(:,j,k), salt_z(:,j,k), press, rho_z(:,j,k), G%HI, eos, US) + call calculate_density(temp_z(:,j,k), salt_z(:,j,k), press, rho_z(:,j,k), eos, US, & + dom=EOS_domain(G%HI)) enddo ; enddo call pass_var(temp_z,G%Domain) diff --git a/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 b/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 index 744a801391..fa1504b431 100644 --- a/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 +++ b/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 @@ -19,7 +19,7 @@ module MOM_mixed_layer_restrat use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : thermo_var_ptrs use MOM_verticalGrid, only : verticalGrid_type -use MOM_EOS, only : calculate_density +use MOM_EOS, only : calculate_density, EOS_domain implicit none ; private @@ -207,8 +207,8 @@ subroutine mixedlayer_restrat_general(h, uhtr, vhtr, tv, forces, dt, MLD_in, Var pRef_MLD(:) = 0. do j = js-1, je+1 dK(:) = 0.5 * h(:,j,1) ! Depth of center of surface layer - call calculate_density(tv%T(:,j,1), tv%S(:,j,1), pRef_MLD, rhoSurf, G%HI, & - tv%eqn_of_state, US, halo=1) + call calculate_density(tv%T(:,j,1), tv%S(:,j,1), pRef_MLD, rhoSurf, tv%eqn_of_state, & + US, dom=EOS_domain(G%HI, halo=1)) deltaRhoAtK(:) = 0. MLD_fast(:,j) = 0. do k = 2, nz @@ -216,8 +216,8 @@ subroutine mixedlayer_restrat_general(h, uhtr, vhtr, tv, forces, dt, MLD_in, Var dK(:) = dK(:) + 0.5 * ( h(:,j,k) + h(:,j,k-1) ) ! Depth of center of layer K ! Mixed-layer depth, using sigma-0 (surface reference pressure) deltaRhoAtKm1(:) = deltaRhoAtK(:) ! Store value from previous iteration of K - call calculate_density(tv%T(:,j,k), tv%S(:,j,k), pRef_MLD, deltaRhoAtK, G%HI, & - tv%eqn_of_state, US, halo=1) + call calculate_density(tv%T(:,j,k), tv%S(:,j,k), pRef_MLD, deltaRhoAtK, tv%eqn_of_state, & + US, dom=EOS_domain(G%HI, halo=1)) do i = is-1,ie+1 deltaRhoAtK(i) = deltaRhoAtK(i) - rhoSurf(i) ! Density difference between layer K and surface enddo @@ -322,7 +322,8 @@ subroutine mixedlayer_restrat_general(h, uhtr, vhtr, tv, forces, dt, MLD_in, Var h_avail(i,j,k) = max(I4dt*G%areaT(i,j)*(h(i,j,k)-GV%Angstrom_H),0.0) enddo if (keep_going) then - call calculate_density(tv%T(:,j,k), tv%S(:,j,k), p0, rho_ml(:), G%HI, tv%eqn_of_state, US, halo=1) + call calculate_density(tv%T(:,j,k), tv%S(:,j,k), p0, rho_ml(:), tv%eqn_of_state, & + US, dom=EOS_domain(G%HI, halo=1)) line_is_empty = .true. do i=is-1,ie+1 if (htot_fast(i,j) < MLD_fast(i,j)) then @@ -646,7 +647,8 @@ subroutine mixedlayer_restrat_BML(h, uhtr, vhtr, tv, forces, dt, G, GV, US, CS) htot(i,j) = 0.0 ; Rml_av(i,j) = 0.0 enddo do k=1,nkml - call calculate_density(tv%T(:,j,k), tv%S(:,j,k), p0, Rho0(:), G%HI, tv%eqn_of_state, US, halo=1) + call calculate_density(tv%T(:,j,k), tv%S(:,j,k), p0, Rho0(:), tv%eqn_of_state, & + US, dom=EOS_domain(G%HI, halo=1)) do i=is-1,ie+1 Rml_av(i,j) = Rml_av(i,j) + h(i,j,k)*Rho0(i) htot(i,j) = htot(i,j) + h(i,j,k) diff --git a/src/parameterizations/lateral/MOM_thickness_diffuse.F90 b/src/parameterizations/lateral/MOM_thickness_diffuse.F90 index 4d42f05629..62f1dad445 100644 --- a/src/parameterizations/lateral/MOM_thickness_diffuse.F90 +++ b/src/parameterizations/lateral/MOM_thickness_diffuse.F90 @@ -9,7 +9,7 @@ module MOM_thickness_diffuse use MOM_diag_mediator, only : diag_update_remap_grids use MOM_domains, only : pass_var, CORNER, pass_vector use MOM_error_handler, only : MOM_error, FATAL, WARNING, is_root_pe -use MOM_EOS, only : calculate_density, calculate_density_derivs +use MOM_EOS, only : calculate_density, calculate_density_derivs, EOS_domain use MOM_file_parser, only : get_param, log_version, param_file_type use MOM_grid, only : ocean_grid_type use MOM_interface_heights, only : find_eta @@ -1029,8 +1029,8 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV T_v(i) = 0.25*((T(i,j,k) + T(i,j+1,k)) + (T(i,j,k-1) + T(i,j+1,k-1))) S_v(i) = 0.25*((S(i,j,k) + S(i,j+1,k)) + (S(i,j,k-1) + S(i,j+1,k-1))) enddo - call calculate_density_derivs(T_v, S_v, pres_v, drho_dT_v, drho_dS_v, G%HI, & - tv%eqn_of_state, US) + call calculate_density_derivs(T_v, S_v, pres_v, drho_dT_v, drho_dS_v, & + tv%eqn_of_state, US, dom=EOS_domain(G%HI)) endif do i=is,ie if (calc_derivatives) then @@ -1291,8 +1291,8 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV T_v(i) = 0.5*(T(i,j,1) + T(i,j+1,1)) S_v(i) = 0.5*(S(i,j,1) + S(i,j+1,1)) enddo - call calculate_density_derivs(T_v, S_v, pres_v, drho_dT_v, drho_dS_v, G%HI, & - tv%eqn_of_state, US) + call calculate_density_derivs(T_v, S_v, pres_v, drho_dT_v, drho_dS_v, & + tv%eqn_of_state, US, dom=EOS_domain(G%HI)) endif do i=is,ie vhD(i,J,1) = -vhtot(i,J) diff --git a/src/parameterizations/vertical/MOM_CVMix_ddiff.F90 b/src/parameterizations/vertical/MOM_CVMix_ddiff.F90 index 1bcb6a1266..f169147d03 100644 --- a/src/parameterizations/vertical/MOM_CVMix_ddiff.F90 +++ b/src/parameterizations/vertical/MOM_CVMix_ddiff.F90 @@ -236,8 +236,7 @@ subroutine compute_ddiff_coeffs(h, tv, G, GV, US, j, Kd_T, Kd_S, CS) 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) + call calculate_density_derivs(temp_int, salt_int, pres_int, drho_dT, drho_dS, 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" diff --git a/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 b/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 index cc3a6e3f69..2a6dd66c20 100644 --- a/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 +++ b/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 @@ -15,7 +15,7 @@ module MOM_bulk_mixed_layer use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : thermo_var_ptrs use MOM_verticalGrid, only : verticalGrid_type -use MOM_EOS, only : calculate_density, calculate_density_derivs +use MOM_EOS, only : calculate_density, calculate_density_derivs, EOS_domain implicit none ; private @@ -466,12 +466,15 @@ subroutine bulkmixedlayer(h_3d, u_3d, v_3d, tv, fluxes, dt, ea, eb, G, GV, US, C do k=1,CS%nkml ; do i=is,ie p_ref(i) = p_ref(i) + 0.5*(GV%H_to_RZ*GV%g_Earth)*h(i,k) enddo ; enddo - call calculate_density_derivs(T(:,1), S(:,1), p_ref, dR0_dT, dR0_dS, G%HI, tv%eqn_of_state, US) - call calculate_density_derivs(T(:,1), S(:,1), p_ref_cv, dRcv_dT, dRcv_dS, G%HI, & - tv%eqn_of_state, US) + call calculate_density_derivs(T(:,1), S(:,1), p_ref, dR0_dT, dR0_dS, tv%eqn_of_state, & + US, dom=EOS_domain(G%HI)) + call calculate_density_derivs(T(:,1), S(:,1), p_ref_cv, dRcv_dT, dRcv_dS, tv%eqn_of_state, & + US, dom=EOS_domain(G%HI)) do k=1,nz - call calculate_density(T(:,k), S(:,k), p_ref, R0(:,k), G%HI, tv%eqn_of_state, US) - call calculate_density(T(:,k), S(:,k), p_ref_cv, Rcv(:,k), G%HI, tv%eqn_of_state, US) + call calculate_density(T(:,k), S(:,k), p_ref, R0(:,k), tv%eqn_of_state, & + US, dom=EOS_domain(G%HI)) + call calculate_density(T(:,k), S(:,k), p_ref_cv, Rcv(:,k), tv%eqn_of_state, & + US, dom=EOS_domain(G%HI)) enddo if (id_clock_EOS>0) call cpu_clock_end(id_clock_EOS) diff --git a/src/parameterizations/vertical/MOM_diabatic_aux.F90 b/src/parameterizations/vertical/MOM_diabatic_aux.F90 index 3cde9ce91e..ae7adc05eb 100644 --- a/src/parameterizations/vertical/MOM_diabatic_aux.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_aux.F90 @@ -9,7 +9,7 @@ module MOM_diabatic_aux 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 use MOM_diag_mediator, only : diag_ctrl, time_type -use MOM_EOS, only : calculate_density, calculate_TFreeze +use MOM_EOS, only : calculate_density, calculate_TFreeze, EOS_domain use MOM_EOS, only : calculate_specific_vol_derivs, calculate_density_derivs use MOM_error_handler, only : MOM_error, FATAL, WARNING, callTree_showQuery use MOM_error_handler, only : callTree_enter, callTree_leave, callTree_waypoint @@ -446,7 +446,8 @@ subroutine insert_brine(h, tv, G, GV, US, fluxes, nkmb, CS, dt, id_brine_lay) h_2d(i,k) = MAX(h(i,j,k), GV%Angstrom_H) enddo - call calculate_density(T(:,k), S(:,k), p_ref_cv, Rcv(:,k), G%HI, tv%eqn_of_state, US) + call calculate_density(T(:,k), S(:,k), p_ref_cv, Rcv(:,k), tv%eqn_of_state, US, & + dom=EOS_domain(G%HI)) enddo ! First, try to find an interior layer where inserting all the salt @@ -766,7 +767,8 @@ subroutine diagnoseMLDbyDensityDifference(id_MLD, h, tv, densityDiff, G, GV, US, pRef_MLD(:) = 0.0 do j=js,je do i=is,ie ; dK(i) = 0.5 * h(i,j,1) * GV%H_to_Z ; enddo ! Depth of center of surface layer - call calculate_density(tv%T(:,j,1), tv%S(:,j,1), pRef_MLD, rhoSurf, G%HI, tv%eqn_of_state, US) + call calculate_density(tv%T(:,j,1), tv%S(:,j,1), pRef_MLD, rhoSurf, tv%eqn_of_state, US, & + dom=EOS_domain(G%HI)) do i=is,ie deltaRhoAtK(i) = 0. MLD(i,j) = 0. @@ -807,7 +809,8 @@ subroutine diagnoseMLDbyDensityDifference(id_MLD, h, tv, densityDiff, G, GV, US, ! Mixed-layer depth, using sigma-0 (surface reference pressure) do i=is,ie ; deltaRhoAtKm1(i) = deltaRhoAtK(i) ; enddo ! Store value from previous iteration of K - call calculate_density(tv%T(:,j,k), tv%S(:,j,k), pRef_MLD, deltaRhoAtK, G%HI, tv%eqn_of_state, US) + call calculate_density(tv%T(:,j,k), tv%S(:,j,k), pRef_MLD, deltaRhoAtK, tv%eqn_of_state, US, & + dom=EOS_domain(G%HI)) do i = is, ie deltaRhoAtK(i) = deltaRhoAtK(i) - rhoSurf(i) ! Density difference between layer K and surface ddRho = deltaRhoAtK(i) - deltaRhoAtKm1(i) @@ -830,8 +833,10 @@ subroutine diagnoseMLDbyDensityDifference(id_MLD, h, tv, densityDiff, G, GV, US, ! T_deeper(i) = tv%T(i,j,nz) ; S_deeper(i) = tv%S(i,j,nz) ! N2_region_set(i) = .true. ! endif - call calculate_density(T_subML, S_subML, pRef_N2, rho_subML, G%HI, tv%eqn_of_state, US) - call calculate_density(T_deeper, S_deeper, pRef_N2, rho_deeper, G%HI, tv%eqn_of_state, US) + call calculate_density(T_subML, S_subML, pRef_N2, rho_subML, tv%eqn_of_state, US, & + dom=EOS_domain(G%HI)) + call calculate_density(T_deeper, S_deeper, pRef_N2, rho_deeper, tv%eqn_of_state, US, & + dom=EOS_domain(G%HI)) do i=is,ie ; if ((G%mask2dT(i,j)>0.5) .and. N2_region_set(i)) then subMLN2(i,j) = gE_rho0 * (rho_deeper(i) - rho_subML(i)) / (GV%H_to_z * dH_N2(i)) endif ; enddo @@ -1006,7 +1011,7 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t pres(i) = pres(i) + d_pres(i) enddo call calculate_specific_vol_derivs(T2d(:,k), tv%S(:,j,k), p_lay(:), & - dSV_dT(:,j,k), dSV_dS(:,j,k), G%HI, tv%eqn_of_state, US=US) + dSV_dT(:,j,k), dSV_dS(:,j,k), tv%eqn_of_state, US=US, dom=EOS_domain(G%HI)) do i=is,ie ; dSV_dT_2d(i,k) = dSV_dT(i,j,k) ; enddo enddo pen_TKE_2d(:,:) = 0.0 @@ -1347,8 +1352,8 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t do i=is,ie ; do nb=1,nsw ; netPen_rate(i) = netPen_rate(i) + pen_SW_bnd_rate(nb,i) ; enddo ; enddo ! Density derivatives - call calculate_density_derivs(T2d(:,1), tv%S(:,j,1), SurfPressure, dRhodT, dRhodS, G%HI, & - tv%eqn_of_state, US) + call calculate_density_derivs(T2d(:,1), tv%S(:,j,1), SurfPressure, dRhodT, dRhodS, & + tv%eqn_of_state, US, dom=EOS_domain(G%HI)) ! 1. Adjust netSalt to reflect dilution effect of FW flux ! 2. Add in the SW heating for purposes of calculating the net ! surface buoyancy flux affecting the top layer. diff --git a/src/parameterizations/vertical/MOM_diabatic_driver.F90 b/src/parameterizations/vertical/MOM_diabatic_driver.F90 index bdfb6b7a9e..607d02722f 100644 --- a/src/parameterizations/vertical/MOM_diabatic_driver.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_driver.F90 @@ -34,7 +34,7 @@ module MOM_diabatic_driver use MOM_energetic_PBL, only : energetic_PBL_get_MLD use MOM_entrain_diffusive, only : entrainment_diffusive, entrain_diffusive_init use MOM_entrain_diffusive, only : entrain_diffusive_end, entrain_diffusive_CS -use MOM_EOS, only : calculate_density, calculate_TFreeze +use MOM_EOS, only : calculate_density, calculate_TFreeze, EOS_domain use MOM_error_handler, only : MOM_error, FATAL, WARNING, callTree_showQuery,MOM_mesg use MOM_error_handler, only : callTree_enter, callTree_leave, callTree_waypoint use MOM_file_parser, only : get_param, log_version, param_file_type, read_param @@ -2682,8 +2682,8 @@ subroutine layered_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_e do i=is,ie ; p_ref_cv(i) = tv%P_Ref ; enddo !$OMP parallel do default(shared) do j=js,je - call calculate_density(tv%T(:,j,1), tv%S(:,j,1), p_ref_cv, Rcv_ml(:,j), G%HI, & - tv%eqn_of_state, US) + call calculate_density(tv%T(:,j,1), tv%S(:,j,1), p_ref_cv, Rcv_ml(:,j), & + tv%eqn_of_state, US, dom=EOS_domain(G%HI)) enddo call apply_sponge(h, dt, G, GV, US, ea, eb, CS%sponge_CSp, Rcv_ml) else diff --git a/src/parameterizations/vertical/MOM_diapyc_energy_req.F90 b/src/parameterizations/vertical/MOM_diapyc_energy_req.F90 index cde4b9e484..edad667592 100644 --- a/src/parameterizations/vertical/MOM_diapyc_energy_req.F90 +++ b/src/parameterizations/vertical/MOM_diapyc_energy_req.F90 @@ -298,7 +298,7 @@ subroutine diapyc_energy_req_calc(h_in, T_in, S_in, Kd, energy_Kd, dt, tv, & ! Solve the tridiagonal equations for new temperatures. - call calculate_specific_vol_derivs(T0, S0, p_lay, dSV_dT, dSV_dS, 1, nz, tv%eqn_of_state, US=US) + call calculate_specific_vol_derivs(T0, S0, p_lay, dSV_dT, dSV_dS, tv%eqn_of_state, US=US) do k=1,nz dMass = GV%H_to_RZ * h_tr(k) diff --git a/src/parameterizations/vertical/MOM_energetic_PBL.F90 b/src/parameterizations/vertical/MOM_energetic_PBL.F90 index 8b5da8565b..48b265a0e2 100644 --- a/src/parameterizations/vertical/MOM_energetic_PBL.F90 +++ b/src/parameterizations/vertical/MOM_energetic_PBL.F90 @@ -17,8 +17,6 @@ module MOM_energetic_PBL 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 #include diff --git a/src/parameterizations/vertical/MOM_entrain_diffusive.F90 b/src/parameterizations/vertical/MOM_entrain_diffusive.F90 index 100e79aba2..7e8d306ff0 100644 --- a/src/parameterizations/vertical/MOM_entrain_diffusive.F90 +++ b/src/parameterizations/vertical/MOM_entrain_diffusive.F90 @@ -12,7 +12,7 @@ module MOM_entrain_diffusive use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : thermo_var_ptrs use MOM_verticalGrid, only : verticalGrid_type -use MOM_EOS, only : calculate_density, calculate_density_derivs +use MOM_EOS, only : calculate_density, calculate_density_derivs, EOS_domain implicit none ; private @@ -700,7 +700,8 @@ subroutine entrainment_diffusive(h, tv, fluxes, dt, G, GV, US, CS, ea, eb, & call determine_dSkb(h_bl, Sref, Ent_bl, eakb, is, ie, kmb, G, GV, & .true., dS_kb, dS_anom_lim=dS_anom_lim) do k=nz-1,kb_min,-1 - call calculate_density(tv%T(:,j,k), tv%S(:,j,k), pres, Rcv, G%HI, tv%eqn_of_state, US) + call calculate_density(tv%T(:,j,k), tv%S(:,j,k), pres, Rcv, tv%eqn_of_state, US, & + dom=EOS_domain(G%HI)) do i=is,ie if ((k>kb(i)) .and. (F(i,k) > 0.0)) then ! Within a time step, a layer may entrain no more than its @@ -784,7 +785,8 @@ subroutine entrainment_diffusive(h, tv, fluxes, dt, G, GV, US, CS, ea, eb, & else ! not bulkmixedlayer do k=K2,nz-1; - call calculate_density(tv%T(:,j,k), tv%S(:,j,k), pres, Rcv, G%HI, tv%eqn_of_state, US) + call calculate_density(tv%T(:,j,k), tv%S(:,j,k), pres, Rcv, tv%eqn_of_state, US, & + dom=EOS_domain(G%HI)) do i=is,ie ; if (F(i,k) > 0.0) then ! Within a time step, a layer may entrain no more than ! its thickness for correction. This limitation should @@ -849,8 +851,8 @@ subroutine entrainment_diffusive(h, tv, fluxes, dt, G, GV, US, CS, ea, eb, & S_eos(i) = 0.5*(tv%S(i,j,k-1) + tv%S(i,j,k)) endif enddo - call calculate_density_derivs(T_eos, S_eos, pressure, dRho_dT, dRho_dS, G%HI, & - tv%eqn_of_state, US) + call calculate_density_derivs(T_eos, S_eos, pressure, dRho_dT, dRho_dS, & + tv%eqn_of_state, US, dom=EOS_domain(G%HI)) do i=is,ie if ((k>kmb) .and. (k @@ -213,7 +213,8 @@ subroutine RGC_initialize_sponges(G, GV, US, tv, u, v, PF, use_ALE, CSp, ACSp) do i=is-1,ie ; pres(i) = tv%P_Ref ; enddo do j=js,je - call calculate_density(T(:,j,1), S(:,j,1), pres, tmp(:,j), G%HI, tv%eqn_of_state, US) + call calculate_density(T(:,j,1), S(:,j,1), pres, tmp(:,j), tv%eqn_of_state, US, & + dom=EOS_domain(G%HI)) enddo call set_up_sponge_ML_density(tmp, G, CSp) diff --git a/src/user/user_change_diffusivity.F90 b/src/user/user_change_diffusivity.F90 index f33d772352..92b17e13fb 100644 --- a/src/user/user_change_diffusivity.F90 +++ b/src/user/user_change_diffusivity.F90 @@ -10,7 +10,7 @@ module user_change_diffusivity use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : thermo_var_ptrs, vertvisc_type, p3d use MOM_verticalGrid, only : verticalGrid_type -use MOM_EOS, only : calculate_density +use MOM_EOS, only : calculate_density, EOS_domain implicit none ; private @@ -107,11 +107,13 @@ subroutine user_change_diff(h, tv, G, GV, US, CS, Kd_lay, Kd_int, T_f, S_f, Kd_i do j=js,je if (present(T_f) .and. present(S_f)) then do k=1,nz - call calculate_density(T_f(:,j,k), S_f(:,j,k), p_ref, Rcv(:,k), G%HI, tv%eqn_of_state, US) + call calculate_density(T_f(:,j,k), S_f(:,j,k), p_ref, Rcv(:,k), tv%eqn_of_state, US, & + dom=EOS_domain(G%HI)) enddo else do k=1,nz - call calculate_density(tv%T(:,j,k), tv%S(:,j,k), p_ref, Rcv(:,k), G%HI, tv%eqn_of_state, US) + call calculate_density(tv%T(:,j,k), tv%S(:,j,k), p_ref, Rcv(:,k), tv%eqn_of_state, US, & + dom=EOS_domain(G%HI)) enddo endif From 415a6bce2e95fd55cd84e21987a52f53a34a677c Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Fri, 17 Apr 2020 15:48:22 +0000 Subject: [PATCH 201/316] Adds unit conversions to EOS type - As part of the process of disconnected EOS from the unit_scaling_type this adds the necessary unit conversions to the EOS_type. - Initialization is currently donne by passing US to MOM_init() but ultimately it seems passing p_scaling, etc., to MOM_init() would remove all dependency on US. - No APIs other than EOS_init() have been changed yet. --- src/core/MOM.F90 | 2 +- src/equation_of_state/MOM_EOS.F90 | 130 +++++++++++++++++------------- 2 files changed, 73 insertions(+), 59 deletions(-) diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index efd4a80a52..f07fd6a1c4 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -2242,7 +2242,7 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & ! Use the Wright equation of state by default, unless otherwise specified ! Note: this line and the following block ought to be in a separate ! initialization routine for tv. - if (use_EOS) call EOS_init(param_file, CS%tv%eqn_of_state) + if (use_EOS) call EOS_init(param_file, CS%tv%eqn_of_state, US) if (use_temperature) then allocate(CS%tv%TempxPmE(isd:ied,jsd:jed)) ; CS%tv%TempxPmE(:,:) = 0.0 if (use_geothermal) then diff --git a/src/equation_of_state/MOM_EOS.F90 b/src/equation_of_state/MOM_EOS.F90 index 9788c84338..dc74e1dcf7 100644 --- a/src/equation_of_state/MOM_EOS.F90 +++ b/src/equation_of_state/MOM_EOS.F90 @@ -112,6 +112,13 @@ module MOM_EOS real :: dTFr_dS !< The derivative of freezing point with salinity [degC ppt-1] real :: dTFr_dp !< The derivative of freezing point with pressure [degC Pa-1] +! Unit conversion factors (normally used for dimensional testing but could also allow for +! change of units of arguments to functions) + real :: m_to_Z !< A constant that translates distances in meters to the units of depth. + real :: kg_m3_to_R !< A constant that translates kilograms per meter cubed to the units of density. + real :: R_to_kg_m3 !< A constant that translates the units of density to kilograms per meter cubed. + real :: RL2_T2_to_Pa !< Convert pressures from R L2 T-2 to Pa. + ! logical :: test_EOS = .true. ! If true, test the equation of state end type EOS_type @@ -161,7 +168,7 @@ subroutine calculate_density_scalar(T, S, pressure, rho, EOS, rho_ref, US, scale if (.not.associated(EOS)) call MOM_error(FATAL, & "calculate_density_scalar called with an unassociated EOS_type EOS.") - p_scale = 1.0 ; if (present(US)) p_scale = US%RL2_T2_to_Pa + p_scale = 1.0 ; if (present(US)) p_scale = EOS%RL2_T2_to_Pa select case (EOS%form_of_EOS) case (EOS_LINEAR) @@ -180,7 +187,7 @@ subroutine calculate_density_scalar(T, S, pressure, rho, EOS, rho_ref, US, scale end select if (present(US) .or. present(scale)) then - rho_scale = 1.0 ; if (present(US)) rho_scale = US%kg_m3_to_R + rho_scale = 1.0 ; if (present(US)) rho_scale = EOS%kg_m3_to_R if (present(scale)) rho_scale = rho_scale * scale rho = rho_scale * rho endif @@ -210,7 +217,7 @@ subroutine calculate_density_array(T, S, pressure, rho, start, npts, EOS, rho_re if (.not.associated(EOS)) call MOM_error(FATAL, & "calculate_density_array called with an unassociated EOS_type EOS.") - p_scale = 1.0 ; if (present(US)) p_scale = US%RL2_T2_to_Pa + p_scale = 1.0 ; if (present(US)) p_scale = EOS%RL2_T2_to_Pa if (p_scale == 1.0) then select case (EOS%form_of_EOS) @@ -247,7 +254,7 @@ subroutine calculate_density_array(T, S, pressure, rho, start, npts, EOS, rho_re end select endif - rho_scale = 1.0 ; if (present(US)) rho_scale = US%kg_m3_to_R + rho_scale = 1.0 ; if (present(US)) rho_scale = EOS%kg_m3_to_R if (present(scale)) rho_scale = rho_scale * scale if (rho_scale /= 1.0) then do j=start,start+npts-1 ; rho(j) = rho_scale * rho(j) ; enddo @@ -281,15 +288,15 @@ subroutine calculate_density_HI_1d(T, S, pressure, rho, HI, EOS, US, halo) npts = HI%iec - HI%isc + 1 + 2*halo_sz is = HI%isc - halo_sz ; ie = HI%iec + halo_sz - if (US%RL2_T2_to_Pa == 1.0) then + if (EOS%RL2_T2_to_Pa == 1.0) then call calculate_density_array(T, S, pressure, rho, start, npts, EOS) else ! There is rescaling of variables, including pressure. - do i=is,ie ; pres(i) = US%RL2_T2_to_Pa * pressure(i) ; enddo + do i=is,ie ; pres(i) = EOS%RL2_T2_to_Pa * pressure(i) ; enddo call calculate_density_array(T, S, pres, rho, start, npts, EOS) endif - if (US%kg_m3_to_R /= 1.0) then ; do i=is,ie - rho(i) = US%kg_m3_to_R * rho(i) + if (EOS%kg_m3_to_R /= 1.0) then ; do i=is,ie + rho(i) = EOS%kg_m3_to_R * rho(i) enddo ; endif end subroutine calculate_density_HI_1d @@ -361,18 +368,18 @@ subroutine calc_spec_vol_scalar(T, S, pressure, specvol, EOS, spv_ref, US, scale if (.not.associated(EOS)) call MOM_error(FATAL, & "calc_spec_vol_scalar called with an unassociated EOS_type EOS.") - pres(1) = pressure ; if (present(US)) pres(1) = US%RL2_T2_to_Pa*pressure + pres(1) = pressure ; if (present(US)) pres(1) = EOS%RL2_T2_to_Pa*pressure Ta(1) = T ; Sa(1) = S if (present(spv_ref)) then - spv_reference = spv_ref ; if (present(US)) spv_reference = US%kg_m3_to_R*spv_ref + spv_reference = spv_ref ; if (present(US)) spv_reference = EOS%kg_m3_to_R*spv_ref call calculate_spec_vol_array(Ta, Sa, pres, spv, 1, 1, EOS, spv_reference) else call calculate_spec_vol_array(Ta, Sa, pres, spv, 1, 1, EOS) endif specvol = spv(1) - spv_scale = 1.0 ; if (present(US)) spv_scale = US%R_to_kg_m3 + spv_scale = 1.0 ; if (present(US)) spv_scale = EOS%R_to_kg_m3 if (present(scale)) spv_scale = spv_scale * scale if (spv_scale /= 1.0) then specvol = spv_scale * specvol @@ -454,20 +461,20 @@ subroutine calc_spec_vol_HI_1d(T, S, pressure, specvol, HI, EOS, US, halo, spv_r npts = HI%iec - HI%isc + 1 + 2*halo_sz is = HI%isc - halo_sz ; ie = HI%iec + halo_sz - if ((US%RL2_T2_to_Pa == 1.0) .and. (US%R_to_kg_m3 == 1.0)) then + if ((EOS%RL2_T2_to_Pa == 1.0) .and. (EOS%R_to_kg_m3 == 1.0)) then call calculate_spec_vol_array(T, S, pressure, specvol, start, npts, EOS, spv_ref) elseif (present(spv_ref)) then ! This is the same as above, but with some extra work to rescale variables. - do i=is,ie ; pres(i) = US%RL2_T2_to_Pa * pressure(i) ; enddo - spv_reference = US%kg_m3_to_R*spv_ref + do i=is,ie ; pres(i) = EOS%RL2_T2_to_Pa * pressure(i) ; enddo + spv_reference = EOS%kg_m3_to_R*spv_ref call calculate_spec_vol_array(T, S, pres, specvol, start, npts, EOS, spv_reference) else ! There is rescaling of variables, but spv_ref is not present. Passing a 0 value of spv_ref ! changes answers at roundoff for some equations of state, like Wright and UNESCO. - do i=is,ie ; pres(i) = US%RL2_T2_to_Pa * pressure(i) ; enddo + do i=is,ie ; pres(i) = EOS%RL2_T2_to_Pa * pressure(i) ; enddo call calculate_spec_vol_array(T, S, pres, specvol, start, npts, EOS) endif - if (US%R_to_kg_m3 /= 1.0) then ; do i=is,ie - specvol(i) = US%R_to_kg_m3 * specvol(i) + if (EOS%R_to_kg_m3 /= 1.0) then ; do i=is,ie + specvol(i) = EOS%R_to_kg_m3 * specvol(i) enddo ; endif end subroutine calc_spec_vol_HI_1d @@ -578,7 +585,7 @@ subroutine calculate_density_derivs_array(T, S, pressure, drho_dT, drho_dS, star if (.not.associated(EOS)) call MOM_error(FATAL, & "calculate_density_derivs called with an unassociated EOS_type EOS.") - p_scale = 1.0 ; if (present(US)) p_scale = US%RL2_T2_to_Pa + p_scale = 1.0 ; if (present(US)) p_scale = EOS%RL2_T2_to_Pa if (p_scale == 1.0) then select case (EOS%form_of_EOS) @@ -615,7 +622,7 @@ subroutine calculate_density_derivs_array(T, S, pressure, drho_dT, drho_dS, star end select endif - rho_scale = 1.0 ; if (present(US)) rho_scale = US%kg_m3_to_R + rho_scale = 1.0 ; if (present(US)) rho_scale = EOS%kg_m3_to_R if (present(scale)) rho_scale = rho_scale * scale if (rho_scale /= 1.0) then ; do j=start,start+npts-1 drho_dT(j) = rho_scale * drho_dT(j) @@ -652,16 +659,16 @@ subroutine calculate_density_derivs_HI_1d(T, S, pressure, drho_dT, drho_dS, HI, npts = HI%iec - HI%isc + 1 + 2*halo_sz is = HI%isc - halo_sz ; ie = HI%iec + halo_sz - if (US%RL2_T2_to_Pa == 1.0) then + if (EOS%RL2_T2_to_Pa == 1.0) then call calculate_density_derivs_array(T, S, pressure, drho_dT, drho_dS, start, npts, EOS) else - do i=is,ie ; pres(i) = US%RL2_T2_to_Pa * pressure(i) ; enddo + do i=is,ie ; pres(i) = EOS%RL2_T2_to_Pa * pressure(i) ; enddo call calculate_density_derivs_array(T, S, pres, drho_dT, drho_dS, start, npts, EOS) endif - if (US%kg_m3_to_R /= 1.0) then ; do i=is,ie - drho_dT(i) = US%kg_m3_to_R * drho_dT(i) - drho_dS(i) = US%kg_m3_to_R * drho_dS(i) + if (EOS%kg_m3_to_R /= 1.0) then ; do i=is,ie + drho_dT(i) = EOS%kg_m3_to_R * drho_dT(i) + drho_dS(i) = EOS%kg_m3_to_R * drho_dS(i) enddo ; endif end subroutine calculate_density_derivs_HI_1d @@ -690,7 +697,7 @@ subroutine calculate_density_derivs_scalar(T, S, pressure, drho_dT, drho_dS, EOS if (.not.associated(EOS)) call MOM_error(FATAL, & "calculate_density_derivs called with an unassociated EOS_type EOS.") - p_scale = 1.0 ; if (present(US)) p_scale = US%RL2_T2_to_Pa + p_scale = 1.0 ; if (present(US)) p_scale = EOS%RL2_T2_to_Pa select case (EOS%form_of_EOS) case (EOS_LINEAR) @@ -704,7 +711,7 @@ subroutine calculate_density_derivs_scalar(T, S, pressure, drho_dT, drho_dS, EOS call MOM_error(FATAL, "calculate_density_derivs_scalar: EOS%form_of_EOS is not valid.") end select - rho_scale = 1.0 ; if (present(US)) rho_scale = US%kg_m3_to_R + rho_scale = 1.0 ; if (present(US)) rho_scale = EOS%kg_m3_to_R if (present(scale)) rho_scale = rho_scale * scale if (rho_scale /= 1.0) then drho_dT = rho_scale * drho_dT @@ -746,7 +753,7 @@ subroutine calculate_density_second_derivs_array(T, S, pressure, drho_dS_dS, drh if (.not.associated(EOS)) call MOM_error(FATAL, & "calculate_density_derivs called with an unassociated EOS_type EOS.") - p_scale = 1.0 ; if (present(US)) p_scale = US%RL2_T2_to_Pa + p_scale = 1.0 ; if (present(US)) p_scale = EOS%RL2_T2_to_Pa if (p_scale == 1.0) then select case (EOS%form_of_EOS) @@ -779,7 +786,7 @@ subroutine calculate_density_second_derivs_array(T, S, pressure, drho_dS_dS, drh end select endif - rho_scale = 1.0 ; if (present(US)) rho_scale = US%kg_m3_to_R + rho_scale = 1.0 ; if (present(US)) rho_scale = EOS%kg_m3_to_R if (present(scale)) rho_scale = rho_scale * scale if (rho_scale /= 1.0) then ; do j=start,start+npts-1 drho_dS_dS(j) = rho_scale * drho_dS_dS(j) @@ -827,7 +834,7 @@ subroutine calculate_density_second_derivs_scalar(T, S, pressure, drho_dS_dS, dr if (.not.associated(EOS)) call MOM_error(FATAL, & "calculate_density_derivs called with an unassociated EOS_type EOS.") - p_scale = 1.0 ; if (present(US)) p_scale = US%RL2_T2_to_Pa + p_scale = 1.0 ; if (present(US)) p_scale = EOS%RL2_T2_to_Pa select case (EOS%form_of_EOS) case (EOS_LINEAR) @@ -843,7 +850,7 @@ subroutine calculate_density_second_derivs_scalar(T, S, pressure, drho_dS_dS, dr call MOM_error(FATAL, "calculate_density_derivs: EOS%form_of_EOS is not valid.") end select - rho_scale = 1.0 ; if (present(US)) rho_scale = US%kg_m3_to_R + rho_scale = 1.0 ; if (present(US)) rho_scale = EOS%kg_m3_to_R if (present(scale)) rho_scale = rho_scale * scale if (rho_scale /= 1.0) then drho_dS_dS = rho_scale * drho_dS_dS @@ -983,16 +990,16 @@ subroutine calc_spec_vol_derivs_HI_1d(T, S, pressure, dSV_dT, dSV_dS, HI, EOS, U npts = HI%iec - HI%isc + 1 + 2*halo_sz is = HI%isc - halo_sz ; ie = HI%iec + halo_sz - if (US%RL2_T2_to_Pa == 1.0) then + if (EOS%RL2_T2_to_Pa == 1.0) then call calculate_spec_vol_derivs_array(T, S, pressure, dSV_dT, dSV_dS, start, npts, EOS) else - do i=is,ie ; press(i) = US%RL2_T2_to_Pa * pressure(i) ; enddo + do i=is,ie ; press(i) = EOS%RL2_T2_to_Pa * pressure(i) ; enddo call calculate_spec_vol_derivs_array(T, S, press, dSV_dT, dSV_dS, start, npts, EOS) endif - if (US%R_to_kg_m3 /= 1.0) then ; do i=is,ie - dSV_dT(i) = US%R_to_kg_m3 * dSV_dT(i) - dSV_dS(i) = US%R_to_kg_m3 * dSV_dS(i) + if (EOS%R_to_kg_m3 /= 1.0) then ; do i=is,ie + dSV_dT(i) = EOS%R_to_kg_m3 * dSV_dT(i) + dSV_dS(i) = EOS%R_to_kg_m3 * dSV_dS(i) enddo ; endif end subroutine calc_spec_vol_derivs_HI_1d @@ -1141,8 +1148,8 @@ subroutine int_specific_vol_dp(T, S, p_t, p_b, alpha_ref, HI, EOS, & else ; select case (EOS%form_of_EOS) case (EOS_LINEAR) if (present(US)) then - call int_spec_vol_dp_linear(T, S, p_t, p_b, alpha_ref, HI, US%kg_m3_to_R*EOS%Rho_T0_S0, & - US%kg_m3_to_R*EOS%dRho_dT, US%kg_m3_to_R*EOS%dRho_dS, dza, & + call int_spec_vol_dp_linear(T, S, p_t, p_b, alpha_ref, HI, EOS%kg_m3_to_R*EOS%Rho_T0_S0, & + EOS%kg_m3_to_R*EOS%dRho_dT, EOS%kg_m3_to_R*EOS%dRho_dS, dza, & intp_dza, intx_dza, inty_dza, halo_size, & bathyP, dP_tiny, useMassWghtInterp) else @@ -1155,7 +1162,7 @@ subroutine int_specific_vol_dp(T, S, p_t, p_b, alpha_ref, HI, EOS, & if (present(US)) then call int_spec_vol_dp_wright(T, S, p_t, p_b, alpha_ref, HI, dza, intp_dza, intx_dza, & inty_dza, halo_size, bathyP, dP_tiny, useMassWghtInterp, & - SV_scale=US%R_to_kg_m3, pres_scale=US%RL2_T2_to_Pa) + SV_scale=EOS%R_to_kg_m3, pres_scale=EOS%RL2_T2_to_Pa) else call int_spec_vol_dp_wright(T, S, p_t, p_b, alpha_ref, HI, dza, intp_dza, intx_dza, & inty_dza, halo_size, bathyP, dP_tiny, useMassWghtInterp) @@ -1227,7 +1234,7 @@ subroutine int_density_dz(T, S, z_t, z_b, rho_ref, rho_0, G_e, HII, HIO, EOS, dp intz_dpa, intx_dpa, inty_dpa, bathyT, dz_neglect, useMassWghtInterp, US) else ; select case (EOS%form_of_EOS) case (EOS_LINEAR) - rho_scale = 1.0 ; if (present(US)) rho_scale = US%kg_m3_to_R + rho_scale = 1.0 ; if (present(US)) rho_scale = EOS%kg_m3_to_R if (rho_scale /= 1.0) then call int_density_dz_linear(T, S, z_t, z_b, rho_ref, rho_0, G_e, HII, HIO, & rho_scale*EOS%Rho_T0_S0, rho_scale*EOS%dRho_dT, rho_scale*EOS%dRho_dS, & @@ -1238,8 +1245,8 @@ subroutine int_density_dz(T, S, z_t, z_b, rho_ref, rho_0, G_e, HII, HIO, EOS, dp dpa, intz_dpa, intx_dpa, inty_dpa, bathyT, dz_neglect, useMassWghtInterp) endif case (EOS_WRIGHT) - rho_scale = 1.0 ; if (present(US)) rho_scale = US%kg_m3_to_R - pres_scale = 1.0 ; if (present(US)) pres_scale = US%RL2_T2_to_Pa + rho_scale = 1.0 ; if (present(US)) rho_scale = EOS%kg_m3_to_R + pres_scale = 1.0 ; if (present(US)) pres_scale = EOS%RL2_T2_to_Pa if ((rho_scale /= 1.0) .or. (pres_scale /= 1.0)) then 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, bathyT, & @@ -1267,9 +1274,11 @@ logical function query_compressible(EOS) end function query_compressible !> Initializes EOS_type by allocating and reading parameters -subroutine EOS_init(param_file, EOS) +subroutine EOS_init(param_file, EOS, US) type(param_file_type), intent(in) :: param_file !< Parameter file structure type(EOS_type), pointer :: EOS !< Equation of state structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + optional :: US ! Local variables #include "version_variable.h" character(len=40) :: mdl = "MOM_EOS" ! This module's name. @@ -1363,6 +1372,11 @@ subroutine EOS_init(param_file, EOS) "should only be used along with TFREEZE_FORM = TFREEZE_TEOS10 .") endif + ! Unit conversions + EOS%m_to_Z = 1. ; if (present(US)) EOS%m_to_Z = US%m_to_Z + EOS%kg_m3_to_R = 1. ; if (present(US)) EOS%kg_m3_to_R = US%kg_m3_to_R + EOS%R_to_kg_m3 = 1. ; if (present(US)) EOS%R_to_kg_m3 = US%R_to_kg_m3 + EOS%RL2_T2_to_Pa = 1. ; if (present(US)) EOS%RL2_T2_to_Pa = US%RL2_T2_to_Pa end subroutine EOS_init @@ -1521,9 +1535,9 @@ subroutine int_density_dz_generic(T, S, z_t, z_b, rho_ref, rho_0, G_e, HII, HIO, is = HIO%isc + ioff ; ie = HIO%iec + ioff js = HIO%jsc + joff ; je = HIO%jec + joff - rho_scale = 1.0 ; if (present(US)) rho_scale = US%kg_m3_to_R - GxRho = G_e * rho_0 ; if (present(US)) GxRho = US%RL2_T2_to_Pa * G_e * rho_0 - rho_ref_mks = rho_ref ; if (present(US)) rho_ref_mks = rho_ref * US%R_to_kg_m3 + rho_scale = 1.0 ; if (present(US)) rho_scale = EOS%kg_m3_to_R + GxRho = G_e * rho_0 ; if (present(US)) GxRho = EOS%RL2_T2_to_Pa * G_e * rho_0 + rho_ref_mks = rho_ref ; if (present(US)) rho_ref_mks = rho_ref * EOS%R_to_kg_m3 I_Rho = 1.0 / rho_0 do_massWeight = .false. @@ -1748,9 +1762,9 @@ subroutine int_density_dz_generic_plm (T_t, T_b, S_t, S_b, z_t, z_b, rho_ref, & Isq = HIO%IscB ; Ieq = HIO%IecB ; Jsq = HIO%JscB ; Jeq = HIO%JecB - rho_scale = 1.0 ; if (present(US)) rho_scale = US%kg_m3_to_R - GxRho = G_e * rho_0 ; if (present(US)) GxRho = US%RL2_T2_to_Pa * G_e * rho_0 - rho_ref_mks = rho_ref ; if (present(US)) rho_ref_mks = rho_ref * US%R_to_kg_m3 + rho_scale = 1.0 ; if (present(US)) rho_scale = EOS%kg_m3_to_R + GxRho = G_e * rho_0 ; if (present(US)) GxRho = EOS%RL2_T2_to_Pa * G_e * rho_0 + rho_ref_mks = rho_ref ; if (present(US)) rho_ref_mks = rho_ref * EOS%R_to_kg_m3 I_Rho = 1.0 / rho_0 massWeightToggle = 0. if (present(useMassWghtInterp)) then @@ -2020,7 +2034,7 @@ subroutine find_depth_of_pressure_in_cell(T_t, T_b, S_t, S_b, z_t, z_b, P_t, P_t Pa_left = P_t - P_tgt ! Pa_left < 0 F_r = 1. Pa_right = P_b - P_tgt ! Pa_right > 0 - Pa_tol = GxRho * 1.0e-5*US%m_to_Z + Pa_tol = GxRho * 1.0e-5*EOS%m_to_Z if (present(z_tol)) Pa_tol = GxRho * z_tol F_guess = F_l - Pa_left / (Pa_right - Pa_left) * (F_r - F_l) @@ -2197,9 +2211,9 @@ subroutine int_density_dz_generic_ppm(T, T_t, T_b, S, S_t, S_b, & is = HIO%isc + ioff ; ie = HIO%iec + ioff js = HIO%jsc + joff ; je = HIO%jec + joff - rho_scale = 1.0 ; if (present(US)) rho_scale = US%kg_m3_to_R - GxRho = G_e * rho_0 ; if (present(US)) GxRho = US%RL2_T2_to_Pa * G_e * rho_0 - rho_ref_mks = rho_ref ; if (present(US)) rho_ref_mks = rho_ref * US%R_to_kg_m3 + rho_scale = 1.0 ; if (present(US)) rho_scale = EOS%kg_m3_to_R + GxRho = G_e * rho_0 ; if (present(US)) GxRho = EOS%RL2_T2_to_Pa * G_e * rho_0 + rho_ref_mks = rho_ref ; if (present(US)) rho_ref_mks = rho_ref * EOS%R_to_kg_m3 I_Rho = 1.0 / rho_0 ! ============================= @@ -2639,9 +2653,9 @@ subroutine int_spec_vol_dp_generic(T, S, p_t, p_b, alpha_ref, HI, EOS, 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 - SV_scale = 1.0 ; if (present(US)) SV_scale = US%R_to_kg_m3 - RL2_T2_to_Pa = 1.0 ; if (present(US)) RL2_T2_to_Pa = US%RL2_T2_to_Pa - alpha_ref_mks = alpha_ref ; if (present(US)) alpha_ref_mks = alpha_ref * US%kg_m3_to_R + SV_scale = 1.0 ; if (present(US)) SV_scale = EOS%R_to_kg_m3 + RL2_T2_to_Pa = 1.0 ; if (present(US)) RL2_T2_to_Pa = EOS%RL2_T2_to_Pa + alpha_ref_mks = alpha_ref ; if (present(US)) alpha_ref_mks = alpha_ref * EOS%kg_m3_to_R do_massWeight = .false. if (present(useMassWghtInterp)) then ; if (useMassWghtInterp) then @@ -2863,9 +2877,9 @@ subroutine int_spec_vol_dp_generic_plm(T_t, T_b, S_t, S_b, p_t, p_b, alpha_ref, do_massWeight = .false. if (present(useMassWghtInterp)) do_massWeight = useMassWghtInterp - SV_scale = 1.0 ; if (present(US)) SV_scale = US%R_to_kg_m3 - RL2_T2_to_Pa = 1.0 ; if (present(US)) RL2_T2_to_Pa = US%RL2_T2_to_Pa - alpha_ref_mks = alpha_ref ; if (present(US)) alpha_ref_mks = alpha_ref * US%kg_m3_to_R + SV_scale = 1.0 ; if (present(US)) SV_scale = EOS%R_to_kg_m3 + RL2_T2_to_Pa = 1.0 ; if (present(US)) RL2_T2_to_Pa = EOS%RL2_T2_to_Pa + alpha_ref_mks = alpha_ref ; if (present(US)) alpha_ref_mks = alpha_ref * EOS%kg_m3_to_R do n = 1, 5 ! Note that these are reversed from int_density_dz. wt_t(n) = 0.25 * real(n-1) From c309289b6b6930dc7dc14491be3da4ee91a3c024 Mon Sep 17 00:00:00 2001 From: Andrew Shao Date: Thu, 16 Apr 2020 19:05:45 -0400 Subject: [PATCH 202/316] Add doxygen comments for h_begin in diag_ctrl --- src/framework/MOM_diag_mediator.F90 | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/framework/MOM_diag_mediator.F90 b/src/framework/MOM_diag_mediator.F90 index 1d0d204354..8ec8349e58 100644 --- a/src/framework/MOM_diag_mediator.F90 +++ b/src/framework/MOM_diag_mediator.F90 @@ -332,7 +332,8 @@ module MOM_diag_mediator !> Number of checksum-only diagnostics integer :: num_chksum_diags - real, dimension(:,:,:), allocatable :: h_begin + real, dimension(:,:,:), allocatable :: h_begin !< Layer thicknesses at the beginning of the timestep used + !! for remapping of extensive variables end type diag_ctrl From acf23a413a5b8c13f98ff387c9a3f0654414e30f Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 17 Apr 2020 13:15:36 -0400 Subject: [PATCH 203/316] Use the 'dom=' interface to calculate_density Use the new variant of calculate_density with the 'dom' argument or no array extent argument in calls in 15 files. All answers are bitwise identical. --- src/ALE/MOM_regridding.F90 | 6 +-- src/ALE/coord_adapt.F90 | 10 ++-- src/core/MOM_PressureForce_Montgomery.F90 | 54 ++++++++++--------- src/core/MOM_PressureForce_analytic_FV.F90 | 30 ++++++----- src/core/MOM_PressureForce_blocked_AFV.F90 | 30 ++++++----- src/core/MOM_isopycnal_slopes.F90 | 21 +++++--- src/diagnostics/MOM_wave_speed.F90 | 8 +-- src/diagnostics/MOM_wave_structure.F90 | 4 +- .../MOM_coord_initialization.F90 | 4 +- .../MOM_state_initialization.F90 | 8 +-- .../lateral/MOM_thickness_diffuse.F90 | 24 ++++++--- .../vertical/MOM_geothermal.F90 | 8 +-- .../vertical/MOM_set_viscosity.F90 | 7 +-- src/user/DOME_initialization.F90 | 6 +-- src/user/benchmark_initialization.F90 | 6 +-- 15 files changed, 123 insertions(+), 103 deletions(-) diff --git a/src/ALE/MOM_regridding.F90 b/src/ALE/MOM_regridding.F90 index 1000ba0d32..f6791a3b73 100644 --- a/src/ALE/MOM_regridding.F90 +++ b/src/ALE/MOM_regridding.F90 @@ -1889,8 +1889,7 @@ subroutine convective_adjustment(G, GV, h, tv) do j = G%jsc-1,G%jec+1 ; do i = G%isc-1,G%iec+1 ! Compute densities within current water column - call calculate_density( tv%T(i,j,:), tv%S(i,j,:), p_col, & - densities, 1, GV%ke, tv%eqn_of_state ) + call calculate_density( tv%T(i,j,:), tv%S(i,j,:), p_col, densities, tv%eqn_of_state ) ! Repeat restratification until complete do @@ -1909,8 +1908,7 @@ subroutine convective_adjustment(G, GV, h, tv) tv%S(i,j,k) = S1 ; tv%S(i,j,k+1) = S0 h(i,j,k) = h1 ; h(i,j,k+1) = h0 ! Recompute densities at levels k and k+1 - call calculate_density( tv%T(i,j,k), tv%S(i,j,k), p_col(k), & - densities(k), tv%eqn_of_state ) + call calculate_density( tv%T(i,j,k), tv%S(i,j,k), p_col(k), densities(k), tv%eqn_of_state) call calculate_density( tv%T(i,j,k+1), tv%S(i,j,k+1), p_col(k+1), & densities(k+1), tv%eqn_of_state ) stratified = .false. diff --git a/src/ALE/coord_adapt.F90 b/src/ALE/coord_adapt.F90 index 98bbeb7b10..3a083af2db 100644 --- a/src/ALE/coord_adapt.F90 +++ b/src/ALE/coord_adapt.F90 @@ -156,7 +156,7 @@ subroutine build_adapt_column(CS, G, GV, tv, i, j, zInt, tInt, sInt, h, zNext) 0.5 * (tInt(i,j,2:nz) + tInt(i,j-1,2:nz)), & 0.5 * (sInt(i,j,2:nz) + sInt(i,j-1,2:nz)), & 0.5 * (zInt(i,j,2:nz) + zInt(i,j-1,2:nz)) * GV%H_to_Pa, & - alpha, beta, 2, nz - 1, tv%eqn_of_state) + alpha, beta, tv%eqn_of_state, dom=(/2,nz/)) del2sigma(2:nz) = del2sigma(2:nz) + & (alpha(2:nz) * (tInt(i,j-1,2:nz) - tInt(i,j,2:nz)) + & @@ -168,7 +168,7 @@ subroutine build_adapt_column(CS, G, GV, tv, i, j, zInt, tInt, sInt, h, zNext) 0.5 * (tInt(i,j,2:nz) + tInt(i,j+1,2:nz)), & 0.5 * (sInt(i,j,2:nz) + sInt(i,j+1,2:nz)), & 0.5 * (zInt(i,j,2:nz) + zInt(i,j+1,2:nz)) * GV%H_to_Pa, & - alpha, beta, 2, nz - 1, tv%eqn_of_state) + alpha, beta, tv%eqn_of_state, dom=(/2,nz/)) del2sigma(2:nz) = del2sigma(2:nz) + & (alpha(2:nz) * (tInt(i,j+1,2:nz) - tInt(i,j,2:nz)) + & @@ -180,7 +180,7 @@ subroutine build_adapt_column(CS, G, GV, tv, i, j, zInt, tInt, sInt, h, zNext) 0.5 * (tInt(i,j,2:nz) + tInt(i-1,j,2:nz)), & 0.5 * (sInt(i,j,2:nz) + sInt(i-1,j,2:nz)), & 0.5 * (zInt(i,j,2:nz) + zInt(i-1,j,2:nz)) * GV%H_to_Pa, & - alpha, beta, 2, nz - 1, tv%eqn_of_state) + alpha, beta, tv%eqn_of_state, dom=(/2,nz/)) del2sigma(2:nz) = del2sigma(2:nz) + & (alpha(2:nz) * (tInt(i-1,j,2:nz) - tInt(i,j,2:nz)) + & @@ -192,7 +192,7 @@ subroutine build_adapt_column(CS, G, GV, tv, i, j, zInt, tInt, sInt, h, zNext) 0.5 * (tInt(i,j,2:nz) + tInt(i+1,j,2:nz)), & 0.5 * (sInt(i,j,2:nz) + sInt(i+1,j,2:nz)), & 0.5 * (zInt(i,j,2:nz) + zInt(i+1,j,2:nz)) * GV%H_to_Pa, & - alpha, beta, 2, nz - 1, tv%eqn_of_state) + alpha, beta, tv%eqn_of_state, dom=(/2,nz/)) del2sigma(2:nz) = del2sigma(2:nz) + & (alpha(2:nz) * (tInt(i+1,j,2:nz) - tInt(i,j,2:nz)) + & @@ -206,7 +206,7 @@ subroutine build_adapt_column(CS, G, GV, tv, i, j, zInt, tInt, sInt, h, zNext) ! a positive curvature means we're too light relative to adjacent columns, ! so del2sigma needs to be positive too (push the interface deeper) call calculate_density_derivs(tInt(i,j,:), sInt(i,j,:), zInt(i,j,:) * GV%H_to_Pa, & - alpha, beta, 1, nz + 1, tv%eqn_of_state) + alpha, beta, tv%eqn_of_state, dom=(/1,nz/)) !### This should be (/1,nz+1/) - see 25 lines below. do K = 2, nz ! TODO make lower bound here configurable del2sigma(K) = del2sigma(K) * (0.5 * (h(i,j,k-1) + h(i,j,k))) / & diff --git a/src/core/MOM_PressureForce_Montgomery.F90 b/src/core/MOM_PressureForce_Montgomery.F90 index 0d8cf27dad..618199dde1 100644 --- a/src/core/MOM_PressureForce_Montgomery.F90 +++ b/src/core/MOM_PressureForce_Montgomery.F90 @@ -124,12 +124,13 @@ subroutine PressureForce_Mont_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, pb real :: alpha_Lay(SZK_(G)) ! The specific volume of each layer [R-1 ~> m3 kg-1]. real :: dalpha_int(SZK_(G)+1) ! The change in specific volume across each ! interface [R-1 ~> m3 kg-1]. - integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz, nkmb, start, npts + integer, dimension(2) :: EOSdom ! The computational domain for the equation of state + integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz, nkmb 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 - start = Isq - (G%isd-1) ; npts = G%iec - Isq + 2 + EOSdom(1) = Isq - (G%isd-1) ; EOSdom(2) = G%iec+1 - (G%isd-1) use_p_atm = .false. if (present(p_atm)) then ; if (associated(p_atm)) use_p_atm = .true. ; endif @@ -228,8 +229,8 @@ subroutine PressureForce_Mont_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, pb 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(:), start, npts, & - tv%eqn_of_state, US=US) + call calculate_density(tv%T(:,j,nkmb), tv%S(:,j,nkmb), p_ref, Rho_cv_BL(:), & + tv%eqn_of_state, US=US, dom=EOSdom) 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) @@ -245,8 +246,8 @@ subroutine PressureForce_Mont_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, pb endif !$OMP parallel do default(shared) private(rho_in_situ) do k=1,nz ; do j=Jsq,Jeq+1 - call calculate_density(tv_tmp%T(:,j,k), tv_tmp%S(:,j,k), p_ref, rho_in_situ, start, npts, & - tv%eqn_of_state, US=US) + call calculate_density(tv_tmp%T(:,j,k), tv_tmp%S(:,j,k), p_ref, rho_in_situ, & + tv%eqn_of_state, US=US, dom=EOSdom) do i=Isq,Ieq+1 ; alpha_star(i,j,k) = 1.0 / rho_in_situ(i) ; enddo enddo ; enddo endif ! use_EOS @@ -409,13 +410,14 @@ subroutine PressureForce_Mont_Bouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, pbce, ! gradient terms are to be split into ! barotropic and baroclinic pieces. type(thermo_var_ptrs) :: tv_tmp! A structure of temporary T & S. - integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz, nkmb, start, npts + integer, dimension(2) :: EOSdom ! The computational domain for the equation of state + integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz, nkmb 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 - start = Isq - (G%isd-1) ; npts = G%iec - Isq + 2 + EOSdom(1) = Isq - (G%isd-1) ; EOSdom(2) = G%iec+1 - (G%isd-1) use_p_atm = .false. if (present(p_atm)) then ; if (associated(p_atm)) use_p_atm = .true. ; endif @@ -484,8 +486,8 @@ subroutine PressureForce_Mont_Bouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, pbce, 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(:), start, npts, & - tv%eqn_of_state, US=US) + call calculate_density(tv%T(:,j,nkmb), tv%S(:,j,nkmb), p_ref, Rho_cv_BL(:), & + tv%eqn_of_state, US=US, dom=EOSdom) do k=nkmb+1,nz ; do i=Isq,Ieq+1 if (GV%Rlay(k) < Rho_cv_BL(i)) then @@ -505,8 +507,8 @@ subroutine PressureForce_Mont_Bouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, pbce, ! will come down with a fatal error if there is any compressibility. !$OMP parallel do default(shared) do k=1,nz+1 ; do j=Jsq,Jeq+1 - call calculate_density(tv_tmp%T(:,j,k), tv_tmp%S(:,j,k), p_ref, rho_star(:,j,k), start, npts, & - tv%eqn_of_state, US=US) + call calculate_density(tv_tmp%T(:,j,k), tv_tmp%S(:,j,k), p_ref, rho_star(:,j,k), & + tv%eqn_of_state, US=US, dom=EOSdom) do i=Isq,Ieq+1 ; rho_star(i,j,k) = G_Rho0*rho_star(i,j,k) ; enddo enddo ; enddo endif ! use_EOS @@ -632,10 +634,11 @@ subroutine Set_pbce_Bouss(e, tv, G, GV, US, Rho0, GFS_scale, pbce, rho_star) ! an equation of state. real :: z_neglect ! A thickness that is so small it is usually lost ! in roundoff and can be neglected [Z ~> m]. - integer :: Isq, Ieq, Jsq, Jeq, nz, i, j, k, start, npts + integer, dimension(2) :: EOSdom ! The computational domain for the equation of state + integer :: Isq, Ieq, Jsq, Jeq, nz, i, j, k Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB ; nz = G%ke - start = Isq - (G%isd-1) ; npts = G%iec - Isq + 2 + EOSdom(1) = Isq - (G%isd-1) ; EOSdom(2) = G%iec+1 - (G%isd-1) Rho0xG = Rho0 * GV%g_Earth G_Rho0 = GV%g_Earth / GV%Rho0 @@ -662,8 +665,8 @@ subroutine Set_pbce_Bouss(e, tv, G, GV, US, Rho0, GFS_scale, pbce, rho_star) Ihtot(i) = GV%H_to_Z / ((e(i,j,1)-e(i,j,nz+1)) + z_neglect) press(i) = -Rho0xG*e(i,j,1) enddo - call calculate_density(tv%T(:,j,1), tv%S(:,j,1), press, rho_in_situ, start, npts, & - tv%eqn_of_state, US=US) + call calculate_density(tv%T(:,j,1), tv%S(:,j,1), press, rho_in_situ, & + tv%eqn_of_state, US=US, dom=EOSdom) do i=Isq,Ieq+1 pbce(i,j,1) = G_Rho0*(GFS_scale * rho_in_situ(i)) * GV%H_to_Z enddo @@ -673,8 +676,8 @@ subroutine Set_pbce_Bouss(e, tv, G, GV, US, Rho0, GFS_scale, pbce, rho_star) T_int(i) = 0.5*(tv%T(i,j,k-1)+tv%T(i,j,k)) S_int(i) = 0.5*(tv%S(i,j,k-1)+tv%S(i,j,k)) enddo - call calculate_density_derivs(T_int, S_int, press, dR_dT, dR_dS, start, npts, & - tv%eqn_of_state, US=US) + call calculate_density_derivs(T_int, S_int, press, dR_dT, dR_dS, & + tv%eqn_of_state, US=US, dom=EOSdom) do i=Isq,Ieq+1 pbce(i,j,k) = pbce(i,j,k-1) + G_Rho0 * & ((e(i,j,K) - e(i,j,nz+1)) * Ihtot(i)) * & @@ -733,10 +736,11 @@ subroutine Set_pbce_nonBouss(p, tv, G, GV, US, GFS_scale, pbce, alpha_star) real :: dp_neglect ! A thickness that is so small it is usually lost ! in roundoff and can be neglected [R L2 T-2 ~> Pa]. logical :: use_EOS ! If true, density is calculated from T & S using an equation of state. - integer :: Isq, Ieq, Jsq, Jeq, nz, i, j, k, start, npts + integer, dimension(2) :: EOSdom ! The computational domain for the equation of state + integer :: Isq, Ieq, Jsq, Jeq, nz, i, j, k Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB ; nz = G%ke - start = Isq - (G%isd-1) ; npts = G%iec - Isq + 2 + EOSdom(1) = Isq - (G%isd-1) ; EOSdom(2) = G%iec+1 - (G%isd-1) use_EOS = associated(tv%eqn_of_state) @@ -759,8 +763,8 @@ subroutine Set_pbce_nonBouss(p, tv, G, GV, US, GFS_scale, pbce, alpha_star) else !$OMP parallel do default(shared) private(T_int,S_int,dR_dT,dR_dS,rho_in_situ) do j=Jsq,Jeq+1 - call calculate_density(tv%T(:,j,nz), tv%S(:,j,nz), p(:,j,nz+1), rho_in_situ, start, npts, & - tv%eqn_of_state, US=US) + call calculate_density(tv%T(:,j,nz), tv%S(:,j,nz), p(:,j,nz+1), rho_in_situ, & + tv%eqn_of_state, US=US, dom=EOSdom) do i=Isq,Ieq+1 C_htot(i,j) = dP_dH / ((p(i,j,nz+1)-p(i,j,1)) + dp_neglect) pbce(i,j,nz) = dP_dH / (rho_in_situ(i)) @@ -770,9 +774,9 @@ subroutine Set_pbce_nonBouss(p, tv, G, GV, US, GFS_scale, pbce, alpha_star) T_int(i) = 0.5*(tv%T(i,j,k)+tv%T(i,j,k+1)) S_int(i) = 0.5*(tv%S(i,j,k)+tv%S(i,j,k+1)) enddo - call calculate_density(T_int, S_int, p(:,j,k+1), rho_in_situ, start, npts, tv%eqn_of_state, US=US) - call calculate_density_derivs(T_int, S_int, p(:,j,k+1), dR_dT, dR_dS, start, npts, & - tv%eqn_of_state, US=US) + call calculate_density(T_int, S_int, p(:,j,k+1), rho_in_situ, tv%eqn_of_state, US=US, dom=EOSdom) + call calculate_density_derivs(T_int, S_int, p(:,j,k+1), dR_dT, dR_dS, & + tv%eqn_of_state, US=US, dom=EOSdom) do i=Isq,Ieq+1 pbce(i,j,k) = pbce(i,j,k+1) + ((p(i,j,K+1)-p(i,j,1))*C_htot(i,j)) * & ((dR_dT(i)*(tv%T(i,j,k+1)-tv%T(i,j,k)) + & diff --git a/src/core/MOM_PressureForce_analytic_FV.F90 b/src/core/MOM_PressureForce_analytic_FV.F90 index f0a4485399..b32d81fdbc 100644 --- a/src/core/MOM_PressureForce_analytic_FV.F90 +++ b/src/core/MOM_PressureForce_analytic_FV.F90 @@ -176,13 +176,14 @@ subroutine PressureForce_AFV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p real :: H_to_RL2_T2 ! A factor to convert from thicknesss units (H) to pressure units [R L2 T-2 H-1 ~> Pa H-1]. ! real :: oneatm = 101325.0 ! 1 atm in [Pa] = [kg m-1 s-2] real, parameter :: C1_6 = 1.0/6.0 - integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz, nkmb, start, npts + integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz, nkmb + integer, dimension(2) :: EOSdom 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 - start = Isq - (G%isd-1) ; npts = G%iec - Isq + 2 + EOSdom(1) = Isq - (G%isd-1) ; EOSdom(2) = G%iec+1 - (G%isd-1) if (.not.associated(CS)) call MOM_error(FATAL, & "MOM_PressureForce_AFV_nonBouss: Module must be initialized before it is used.") @@ -228,8 +229,8 @@ subroutine PressureForce_AFV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p 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(:), start, npts, & - tv%eqn_of_state, US=US) + call calculate_density(tv%T(:,j,nkmb), tv%S(:,j,nkmb), p_ref, Rho_cv_BL(:), & + tv%eqn_of_state, US=US, dom=EOSdom) 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) @@ -334,8 +335,8 @@ subroutine PressureForce_AFV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p 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, start, npts, & - tv%eqn_of_state, US=US) + call calculate_density(tv_tmp%T(:,j,1), tv_tmp%S(:,j,1), p(:,j,1), rho_in_situ, & + tv%eqn_of_state, US=US, dom=EOSdom) 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)) @@ -504,13 +505,14 @@ subroutine PressureForce_AFV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_at 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, start, npts + integer, dimension(2) :: EOSdom ! The computational domain for the equation of state + integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz, nkmb 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 - start = Isq - (G%isd-1) ; npts = G%iec - Isq + 2 + EOSdom(1) = Isq - (G%isd-1) ; EOSdom(2) = G%iec+1 - (G%isd-1) if (.not.associated(CS)) call MOM_error(FATAL, & "MOM_PressureForce_AFV_Bouss: Module must be initialized before it is used.") @@ -578,8 +580,8 @@ subroutine PressureForce_AFV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_at 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(:), start, npts, & - tv%eqn_of_state, US=US) + call calculate_density(tv%T(:,j,nkmb), tv%S(:,j,nkmb), p_ref, Rho_cv_BL(:), & + tv%eqn_of_state, US=US, dom=EOSdom) do k=nkmb+1,nz ; do i=Isq,Ieq+1 if (GV%Rlay(k) < Rho_cv_BL(i)) then @@ -601,11 +603,11 @@ subroutine PressureForce_AFV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_at !$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, start, npts, & - tv%eqn_of_state, US=US) + call calculate_density(tv_tmp%T(:,j,1), tv_tmp%S(:,j,1), p_atm(:,j), rho_in_situ, & + tv%eqn_of_state, US=US, dom=EOSdom) else - call calculate_density(tv_tmp%T(:,j,1), tv_tmp%S(:,j,1), p0, rho_in_situ, start, npts, & - tv%eqn_of_state, US=US) + call calculate_density(tv_tmp%T(:,j,1), tv_tmp%S(:,j,1), p0, rho_in_situ, & + tv%eqn_of_state, US=US, dom=EOSdom) endif do i=Isq,Ieq+1 dM(i,j) = (CS%GFS_scale - 1.0) * (G_Rho0 * rho_in_situ(i)) * e(i,j,1) diff --git a/src/core/MOM_PressureForce_blocked_AFV.F90 b/src/core/MOM_PressureForce_blocked_AFV.F90 index 5ac7831479..8e2f3c1405 100644 --- a/src/core/MOM_PressureForce_blocked_AFV.F90 +++ b/src/core/MOM_PressureForce_blocked_AFV.F90 @@ -173,14 +173,15 @@ subroutine PressureForce_blk_AFV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, real :: H_to_RL2_T2 ! A factor to convert from thicknesss units (H) to pressure units [R L2 T-2 H-1 ~> Pa H-1]. ! real :: oneatm = 101325.0 ! 1 atm in [Pa] = [kg m-1 s-2] real, parameter :: C1_6 = 1.0/6.0 - integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz, nkmb, start, npts + integer, dimension(2) :: EOSdom ! The computational domain for the equation of state + 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 - start = Isq - (G%isd-1) ; npts = G%iec - Isq + 2 + EOSdom(1) = Isq - (G%isd-1) ; EOSdom(2) = G%iec+1 - (G%isd-1) if (.not.associated(CS)) call MOM_error(FATAL, & "MOM_PressureForce_AFV_nonBouss: Module must be initialized before it is used.") @@ -224,8 +225,8 @@ subroutine PressureForce_blk_AFV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, 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(:), start, npts, & - tv%eqn_of_state, US=US) + call calculate_density(tv%T(:,j,nkmb), tv%S(:,j,nkmb), p_ref, Rho_cv_BL(:), & + tv%eqn_of_state, US=US, dom=EOSdom) 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) @@ -302,8 +303,8 @@ subroutine PressureForce_blk_AFV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, 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, start, npts, & - tv%eqn_of_state, US=US) + call calculate_density(tv_tmp%T(:,j,1), tv_tmp%S(:,j,1), p(:,j,1), rho_in_situ, & + tv%eqn_of_state, US=US, dom=EOSdom) 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)) @@ -489,7 +490,8 @@ subroutine PressureForce_blk_AFV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, 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, start, npts + integer, dimension(2) :: EOSdom ! The computational domain for the equation of state + 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 @@ -497,7 +499,7 @@ subroutine PressureForce_blk_AFV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, 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 - start = Isq - (G%isd-1) ; npts = G%iec - Isq + 2 + EOSdom(1) = Isq - (G%isd-1) ; EOSdom(2) = G%iec+1 - (G%isd-1) if (.not.associated(CS)) call MOM_error(FATAL, & "MOM_PressureForce_AFV_Bouss: Module must be initialized before it is used.") @@ -565,8 +567,8 @@ subroutine PressureForce_blk_AFV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, 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(:), start, npts, & - tv%eqn_of_state, US=US) + call calculate_density(tv%T(:,j,nkmb), tv%S(:,j,nkmb), p_ref, Rho_cv_BL(:), & + tv%eqn_of_state, US=US, dom=EOSdom) do k=nkmb+1,nz ; do i=Isq,Ieq+1 if (GV%Rlay(k) < Rho_cv_BL(i)) then @@ -588,11 +590,11 @@ subroutine PressureForce_blk_AFV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, !$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, start, npts, & - tv%eqn_of_state, US=US) + call calculate_density(tv_tmp%T(:,j,1), tv_tmp%S(:,j,1), p_atm(:,j), rho_in_situ, & + tv%eqn_of_state, US=US, dom=EOSdom) else - call calculate_density(tv_tmp%T(:,j,1), tv_tmp%S(:,j,1), p0, rho_in_situ, start, npts, & - tv%eqn_of_state, US=US) + call calculate_density(tv_tmp%T(:,j,1), tv_tmp%S(:,j,1), p0, rho_in_situ, & + tv%eqn_of_state, US=US, dom=EOSdom) endif do i=Isq,Ieq+1 dM(i,j) = (CS%GFS_scale - 1.0) * (G_Rho0 * rho_in_situ(i)) * e(i,j,1) diff --git a/src/core/MOM_isopycnal_slopes.F90 b/src/core/MOM_isopycnal_slopes.F90 index 78fdc51077..42d8abe308 100644 --- a/src/core/MOM_isopycnal_slopes.F90 +++ b/src/core/MOM_isopycnal_slopes.F90 @@ -99,6 +99,7 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, & real :: H_to_Z ! A conversion factor from thickness units to the units of e. logical :: present_N2_u, present_N2_v + integer, dimension(2) :: EOSdom_u, EOSdom_v ! Domains for the equation of state calculations at u and v points integer :: is, ie, js, je, nz, IsdB integer :: i, j, k @@ -155,9 +156,11 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, & enddo ; enddo enddo - !$OMP parallel do default(none) shared(nz,is,ie,js,je,IsdB,use_EOS,G,GV,US,pres,T,S,tv, & - !$OMP h,h_neglect,e,dz_neglect,Z_to_L,L_to_Z,H_to_Z, & - !$OMP h_neglect2,present_N2_u,G_Rho0,N2_u,slope_x) & + EOSdom_u(1) = is-1 - (G%IsdB-1) ; EOSdom_u(2) = ie - (G%IsdB-1) + + !$OMP parallel do default(none) shared(nz,is,ie,js,je,IsdB,use_EOS,G,GV,US,pres,T,S,tv,h,e, & + !$OMP h_neglect,dz_neglect,Z_to_L,L_to_Z,H_to_Z,h_neglect2, & + !$OMP present_N2_u,G_Rho0,N2_u,slope_x,EOSdom_u) & !$OMP private(drdiA,drdiB,drdkL,drdkR,pres_u,T_u,S_u, & !$OMP drho_dT_u,drho_dS_u,hg2A,hg2B,hg2L,hg2R,haA, & !$OMP haB,haL,haR,dzaL,dzaR,wtA,wtB,wtL,wtR,drdz, & @@ -175,8 +178,8 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, & T_u(I) = 0.25*((T(i,j,k) + T(i+1,j,k)) + (T(i,j,k-1) + T(i+1,j,k-1))) S_u(I) = 0.25*((S(i,j,k) + S(i+1,j,k)) + (S(i,j,k-1) + S(i+1,j,k-1))) enddo - call calculate_density_derivs(T_u, S_u, pres_u, drho_dT_u, drho_dS_u, (is-IsdB+1)-1, ie-is+2, & - tv%eqn_of_state, US=US) + call calculate_density_derivs(T_u, S_u, pres_u, drho_dT_u, drho_dS_u, & + tv%eqn_of_state, US=US, dom=EOSdom_u) endif do I=is-1,ie @@ -241,10 +244,12 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, & enddo ! I enddo ; enddo ! end of j-loop + EOSdom_v(1) = is - (G%isd-1) ; EOSdom_v(2) = ie - (G%isd-1) + ! Calculate the meridional isopycnal slope. !$OMP parallel do default(none) shared(nz,is,ie,js,je,IsdB,use_EOS,G,GV,US,pres,T,S,tv, & !$OMP h,h_neglect,e,dz_neglect,Z_to_L,L_to_Z,H_to_Z, & - !$OMP h_neglect2,present_N2_v,G_Rho0,N2_v,slope_y) & + !$OMP h_neglect2,present_N2_v,G_Rho0,N2_v,slope_y,EOSdom_v) & !$OMP private(drdjA,drdjB,drdkL,drdkR,pres_v,T_v,S_v, & !$OMP drho_dT_v,drho_dS_v,hg2A,hg2B,hg2L,hg2R,haA, & !$OMP haB,haL,haR,dzaL,dzaR,wtA,wtB,wtL,wtR,drdz, & @@ -261,8 +266,8 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, & T_v(i) = 0.25*((T(i,j,k) + T(i,j+1,k)) + (T(i,j,k-1) + T(i,j+1,k-1))) S_v(i) = 0.25*((S(i,j,k) + S(i,j+1,k)) + (S(i,j,k-1) + S(i,j+1,k-1))) enddo - call calculate_density_derivs(T_v, S_v, pres_v, drho_dT_v, drho_dS_v, is, ie-is+1, & - tv%eqn_of_state, US=US) + call calculate_density_derivs(T_v, S_v, pres_v, drho_dT_v, drho_dS_v, tv%eqn_of_state, & + US=US, dom=EOSdom_v) endif do i=is,ie if (use_EOS) then diff --git a/src/diagnostics/MOM_wave_speed.F90 b/src/diagnostics/MOM_wave_speed.F90 index 85dbcdc13b..e1835261aa 100644 --- a/src/diagnostics/MOM_wave_speed.F90 +++ b/src/diagnostics/MOM_wave_speed.F90 @@ -242,8 +242,8 @@ subroutine wave_speed(h, tv, G, GV, US, cg1, CS, full_halos, use_ebt_mode, & T_int(k) = 0.5*(Tf(k,i)+Tf(k-1,i)) S_int(k) = 0.5*(Sf(k,i)+Sf(k-1,i)) enddo - call calculate_density_derivs(T_int, S_int, pres, drho_dT, drho_dS, 2, & - kf(i)-1, tv%eqn_of_state, US) + call calculate_density_derivs(T_int, S_int, pres, drho_dT, drho_dS, & + tv%eqn_of_state, US, dom=(/2,kf(i)/)) ! Sum the reduced gravities to find out how small a density difference ! is negligibly small. @@ -737,8 +737,8 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, full_halos) T_int(k) = 0.5*(Tf(k,i)+Tf(k-1,i)) S_int(k) = 0.5*(Sf(k,i)+Sf(k-1,i)) enddo - call calculate_density_derivs(T_int, S_int, pres, drho_dT, drho_dS, 2, & - kf(i)-1, tv%eqn_of_state, US) + call calculate_density_derivs(T_int, S_int, pres, drho_dT, drho_dS, & + tv%eqn_of_state, US, dom=(/2,kf(i)/)) ! Sum the reduced gravities to find out how small a density difference ! is negligibly small. diff --git a/src/diagnostics/MOM_wave_structure.F90 b/src/diagnostics/MOM_wave_structure.F90 index ceb6fd6c4f..bc5a06e0ea 100644 --- a/src/diagnostics/MOM_wave_structure.F90 +++ b/src/diagnostics/MOM_wave_structure.F90 @@ -277,8 +277,8 @@ subroutine wave_structure(h, tv, G, GV, US, cn, ModeNum, freq, CS, En, full_halo T_int(k) = 0.5*(Tf(k,i)+Tf(k-1,i)) S_int(k) = 0.5*(Sf(k,i)+Sf(k-1,i)) enddo - call calculate_density_derivs(T_int, S_int, pres, drho_dT, drho_dS, 2, & - kf(i)-1, tv%eqn_of_state, US) + call calculate_density_derivs(T_int, S_int, pres, drho_dT, drho_dS, & + tv%eqn_of_state, US, dom=(/2,kf(i)/)) ! Sum the reduced gravities to find out how small a density difference ! is negligibly small. diff --git a/src/initialization/MOM_coord_initialization.F90 b/src/initialization/MOM_coord_initialization.F90 index b0155ae603..42a02a70ff 100644 --- a/src/initialization/MOM_coord_initialization.F90 +++ b/src/initialization/MOM_coord_initialization.F90 @@ -291,7 +291,7 @@ subroutine set_coord_from_TS_profile(Rlay, g_prime, GV, US, param_file, eqn_of_s ! These statements set the interface reduced gravities. ! g_prime(1) = g_fs do k=1,nz ; Pref(k) = P_Ref ; enddo - call calculate_density(T0, S0, Pref, Rlay, 1, nz, eqn_of_state, US=US) + call calculate_density(T0, S0, Pref, Rlay, eqn_of_state, US=US, dom=(/1,nz/)) do k=2,nz; g_prime(k) = (GV%g_Earth/(GV%Rho0)) * (Rlay(k) - Rlay(k-1)) ; enddo call callTree_leave(trim(mdl)//'()') @@ -371,7 +371,7 @@ subroutine set_coord_from_TS_range(Rlay, g_prime, GV, US, param_file, eqn_of_sta g_prime(1) = g_fs do k=1,nz ; Pref(k) = P_Ref ; enddo - call calculate_density(T0, S0, Pref, Rlay, k_light, nz-k_light+1, eqn_of_state, US=US) + call calculate_density(T0, S0, Pref, Rlay, eqn_of_state, US=US, dom=(/k_light,nz/) ) ! Extrapolate target densities for the variable density mixed and buffer layers. do k=k_light-1,1,-1 Rlay(k) = 2.0*Rlay(k+1) - Rlay(k+2) diff --git a/src/initialization/MOM_state_initialization.F90 b/src/initialization/MOM_state_initialization.F90 index 2ac8ac47bf..76e87aeed2 100644 --- a/src/initialization/MOM_state_initialization.F90 +++ b/src/initialization/MOM_state_initialization.F90 @@ -1610,8 +1610,8 @@ subroutine initialize_temp_salt_fit(T, S, G, GV, US, param_file, eqn_of_state, P enddo ! Refine the guesses for each layer. do itt=1,6 - call calculate_density(T0, S0, pres, rho_guess, 1, nz, eqn_of_state, US=US) - call calculate_density_derivs(T0, S0, pres, drho_dT, drho_dS, 1, nz, eqn_of_state, US=US) + call calculate_density(T0, S0, pres, rho_guess, eqn_of_state, US=US) + call calculate_density_derivs(T0, S0, pres, drho_dT, drho_dS, eqn_of_state, US=US) do k=1,nz S0(k) = max(0.0, S0(k) + (GV%Rlay(k) - rho_guess(k)) / drho_dS(k)) enddo @@ -1622,8 +1622,8 @@ subroutine initialize_temp_salt_fit(T, S, G, GV, US, param_file, eqn_of_state, P T0(k) = T0(1) + (GV%Rlay(k) - rho_guess(1)) / drho_dT(1) enddo do itt=1,6 - call calculate_density(T0, S0, pres, rho_guess, 1, nz, eqn_of_state, US=US) - call calculate_density_derivs(T0, S0, pres, drho_dT, drho_dS, 1, nz, eqn_of_state, US=US) + call calculate_density(T0, S0, pres, rho_guess, eqn_of_state, US=US) + call calculate_density_derivs(T0, S0, pres, drho_dT, drho_dS, eqn_of_state, US=US) do k=1,nz T0(k) = T0(k) + (GV%Rlay(k) - rho_guess(k)) / drho_dT(k) enddo diff --git a/src/parameterizations/lateral/MOM_thickness_diffuse.F90 b/src/parameterizations/lateral/MOM_thickness_diffuse.F90 index 62f1dad445..49d1665b16 100644 --- a/src/parameterizations/lateral/MOM_thickness_diffuse.F90 +++ b/src/parameterizations/lateral/MOM_thickness_diffuse.F90 @@ -672,6 +672,10 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV real, dimension(SZI_(G), SZJB_(G), SZK_(G)+1) :: diag_sfn_y, diag_sfn_unlim_y ! Diagnostics logical :: present_int_slope_u, present_int_slope_v logical :: present_slope_x, present_slope_y, calc_derivatives + integer, dimension(2) :: EOSdom_u ! The shifted i-computational domain to use for equation of + ! state calculations at u-points. + integer, dimension(2) :: EOSdom_v ! The shifted I-computational domain to use for equation of + ! state calculations at v-points. integer :: is, ie, js, je, nz, IsdB integer :: i, j, k is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke ; IsdB = G%IsdB @@ -747,12 +751,13 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV enddo ; enddo !$OMP end parallel + EOSdom_u(1) = (is-1) - (G%IsdB-1) ; EOSdom_u(2) = ie - (G%IsdB-1) !$OMP parallel do default(none) shared(nz,is,ie,js,je,find_work,use_EOS,G,GV,US,pres,T,S, & !$OMP nk_linear,IsdB,tv,h,h_neglect,e,dz_neglect, & !$OMP I_slope_max2,h_neglect2,present_int_slope_u, & !$OMP int_slope_u,KH_u,uhtot,h_frac,h_avail_rsum, & !$OMP uhD,h_avail,G_scale,Work_u,CS,slope_x,cg1, & -!$OMP diag_sfn_x, diag_sfn_unlim_x,N2_floor, & +!$OMP diag_sfn_x, diag_sfn_unlim_x,N2_floor,EOS_dom_u, & !$OMP present_slope_x,G_rho0,Slope_x_PE,hN2_x_PE) & !$OMP private(drdiA,drdiB,drdkL,drdkR,pres_u,T_u,S_u, & !$OMP drho_dT_u,drho_dS_u,hg2A,hg2B,hg2L,hg2R,haA, & @@ -778,8 +783,8 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV T_u(I) = 0.25*((T(i,j,k) + T(i+1,j,k)) + (T(i,j,k-1) + T(i+1,j,k-1))) S_u(I) = 0.25*((S(i,j,k) + S(i+1,j,k)) + (S(i,j,k-1) + S(i+1,j,k-1))) enddo - call calculate_density_derivs(T_u, S_u, pres_u, drho_dT_u, & - drho_dS_u, (is-IsdB+1)-1, ie-is+2, tv%eqn_of_state, US=US) + call calculate_density_derivs(T_u, S_u, pres_u, drho_dT_u, drho_dS_u, & + tv%eqn_of_state, US=US, dom=EOSdom_u) endif do I=is-1,ie @@ -1000,13 +1005,14 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV enddo ! end of j-loop ! Calculate the meridional fluxes and gradients. + EOSdom_v(:) = EOS_domain(G%HI) !$OMP parallel do default(none) shared(nz,is,ie,js,je,find_work,use_EOS,G,GV,US,pres,T,S, & !$OMP nk_linear,IsdB,tv,h,h_neglect,e,dz_neglect, & !$OMP I_slope_max2,h_neglect2,present_int_slope_v, & !$OMP int_slope_v,KH_v,vhtot,h_frac,h_avail_rsum, & !$OMP vhD,h_avail,G_scale,Work_v,CS,slope_y,cg1, & -!$OMP diag_sfn_y, diag_sfn_unlim_y,N2_floor, & -!$OMP present_slope_y,G_rho0,Slope_y_PE,hN2_y_PE) & +!$OMP diag_sfn_y,diag_sfn_unlim_y,N2_floor,EOSdom_v,& +!$OMP present_slope_y,G_rho0,Slope_y_PE,hN2_y_PE) & !$OMP private(drdjA,drdjB,drdkL,drdkR,pres_v,T_v,S_v, & !$OMP drho_dT_v,drho_dS_v,hg2A,hg2B,hg2L,hg2R,haA, & !$OMP haB,haL,haR,dzaL,dzaR,wtA,wtB,wtL,wtR,drdz, & @@ -1030,7 +1036,7 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV S_v(i) = 0.25*((S(i,j,k) + S(i,j+1,k)) + (S(i,j,k-1) + S(i,j+1,k-1))) enddo call calculate_density_derivs(T_v, S_v, pres_v, drho_dT_v, drho_dS_v, & - tv%eqn_of_state, US, dom=EOS_domain(G%HI)) + tv%eqn_of_state, US, dom=EOSdom_v) endif do i=is,ie if (calc_derivatives) then @@ -1253,6 +1259,7 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV do j=js,je ; do I=is-1,ie ; uhD(I,j,1) = -uhtot(I,j) ; enddo ; enddo do J=js-1,je ; do i=is,ie ; vhD(i,J,1) = -vhtot(i,J) ; enddo ; enddo else + EOSdom_u(1) = (is-1) - (G%IsdB-1) ; EOSdom_u(2) = ie - (G%IsdB-1) !$OMP parallel do default(shared) private(pres_u,T_u,S_u,drho_dT_u,drho_dS_u,drdiB) do j=js,je if (use_EOS) then @@ -1262,7 +1269,7 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV S_u(I) = 0.5*(S(i,j,1) + S(i+1,j,1)) enddo call calculate_density_derivs(T_u, S_u, pres_u, drho_dT_u, drho_dS_u, & - (is-IsdB+1)-1, ie-is+2, tv%eqn_of_state, US=US) + tv%eqn_of_state, US=US, dom=EOSdom_u ) endif do I=is-1,ie uhD(I,j,1) = -uhtot(I,j) @@ -1283,6 +1290,7 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV enddo enddo + EOSdom_v(:) = EOS_domain(G%HI) !$OMP parallel do default(shared) private(pres_v,T_v,S_v,drho_dT_v,drho_dS_v,drdjB) do J=js-1,je if (use_EOS) then @@ -1292,7 +1300,7 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV S_v(i) = 0.5*(S(i,j,1) + S(i,j+1,1)) enddo call calculate_density_derivs(T_v, S_v, pres_v, drho_dT_v, drho_dS_v, & - tv%eqn_of_state, US, dom=EOS_domain(G%HI)) + tv%eqn_of_state, US, dom=EOSdom_v) endif do i=is,ie vhD(i,J,1) = -vhtot(i,J) diff --git a/src/parameterizations/vertical/MOM_geothermal.F90 b/src/parameterizations/vertical/MOM_geothermal.F90 index 9b91c6453a..289afd19d2 100644 --- a/src/parameterizations/vertical/MOM_geothermal.F90 +++ b/src/parameterizations/vertical/MOM_geothermal.F90 @@ -198,8 +198,8 @@ subroutine geothermal(h, tv, dt, ea, eb, G, GV, US, CS, halo) iej = is-1 ; do i=ie,is,-1 ; if (do_i(i)) then ; iej = i ; exit ; endif ; enddo if (nkmb > 0) then - call calculate_density(tv%T(:,j,nkmb), tv%S(:,j,nkmb), p_Ref(:), Rcv_BL(:), isj, iej-isj+1, & - tv%eqn_of_state, US=US) + call calculate_density(tv%T(:,j,nkmb), tv%S(:,j,nkmb), p_Ref(:), Rcv_BL(:), & + tv%eqn_of_state, US=US, dom=(/isj-(G%isd-1),iej-(G%isd-1)/)) else Rcv_BL(:) = -1.0 endif @@ -248,8 +248,8 @@ subroutine geothermal(h, tv, dt, ea, eb, G, GV, US, CS, halo) Rcv, tv%eqn_of_state, US=US) T2(1) = tv%T(i,j,k) ; S2(1) = tv%S(i,j,k) T2(2) = tv%T(i,j,k_tgt) ; S2(2) = tv%S(i,j,k_tgt) - call calculate_density_derivs(T2(:), S2(:), p_Ref(:), dRcv_dT_, dRcv_dS_, 1, 2, & - tv%eqn_of_state, US=US) + call calculate_density_derivs(T2(:), S2(:), p_Ref(:), dRcv_dT_, dRcv_dS_, & + tv%eqn_of_state, US=US, dom=(/1,2/) ) dRcv_dT = 0.5*(dRcv_dT_(1) + dRcv_dT_(2)) endif diff --git a/src/parameterizations/vertical/MOM_set_viscosity.F90 b/src/parameterizations/vertical/MOM_set_viscosity.F90 index c628cfd1d3..fadc4874cd 100644 --- a/src/parameterizations/vertical/MOM_set_viscosity.F90 +++ b/src/parameterizations/vertical/MOM_set_viscosity.F90 @@ -273,7 +273,8 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, symmetrize) ! accuracy of a single L(:) Newton iteration logical :: use_L0, do_one_L_iter ! Control flags for L(:) Newton iteration logical :: use_BBL_EOS, do_i(SZIB_(G)) - integer :: i, j, k, is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz, m, n, K2, nkmb, nkml, start, npts + integer, dimension(2) :: EOSdom ! The computational domain for the equation of state + integer :: i, j, k, is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz, m, n, K2, nkmb, nkml integer :: itt, maxitt=20 type(ocean_OBC_type), pointer :: OBC => NULL() @@ -292,7 +293,6 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, symmetrize) if (present(symmetrize)) then ; if (symmetrize) then Jsq = js-1 ; Isq = is-1 endif ; endif - start = Isq - (G%isd-1) ; npts = G%iec - Isq + 2 if (CS%debug) then call uvchksum("Start set_viscous_BBL [uv]", u, v, G%HI, haloshift=1, scale=US%L_T_to_m_s) @@ -313,11 +313,12 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, symmetrize) ! if (CS%linear_drag) ustar(:) = cdrag_sqrt_Z*CS%drag_bg_vel if ((nkml>0) .and. .not.use_BBL_EOS) then + EOSdom(1) = Isq - (G%isd-1) ; EOSdom(2) = G%iec+1 - (G%isd-1) do i=Isq,Ieq+1 ; p_ref(i) = tv%P_Ref ; enddo !$OMP parallel do default(shared) do k=1,nkmb ; do j=Jsq,Jeq+1 call calculate_density(tv%T(:,j,k), tv%S(:,j,k), p_ref, Rml(:,j,k), tv%eqn_of_state, & - US=US, dom=(/start,start+npts-1/)) + US=US, dom=EOSdom) enddo ; enddo endif diff --git a/src/user/DOME_initialization.F90 b/src/user/DOME_initialization.F90 index 315e56051c..de4726dd1d 100644 --- a/src/user/DOME_initialization.F90 +++ b/src/user/DOME_initialization.F90 @@ -360,12 +360,12 @@ subroutine DOME_set_OBC_data(OBC, tv, G, GV, US, param_file, tr_Reg) ! USER_initialize_temp_sal. pres(:) = tv%P_Ref ; S0(:) = 35.0 ; T0(1) = 25.0 call calculate_density(T0(1), S0(1), pres(1), rho_guess(1), tv%eqn_of_state, US=US) - call calculate_density_derivs(T0, S0, pres, drho_dT, drho_dS, 1, 1, tv%eqn_of_state, US=US) + call calculate_density_derivs(T0, S0, pres, drho_dT, drho_dS, tv%eqn_of_state, US=US, dom=(/1,1/)) do k=1,nz ; T0(k) = T0(1) + (GV%Rlay(k)-rho_guess(1)) / drho_dT(1) ; enddo do itt=1,6 - call calculate_density(T0, S0, pres, rho_guess, 1, nz, tv%eqn_of_state, US=US) - call calculate_density_derivs(T0, S0, pres, drho_dT, drho_dS, 1, nz, tv%eqn_of_state, US=US) + call calculate_density(T0, S0, pres, rho_guess, tv%eqn_of_state, US=US) + call calculate_density_derivs(T0, S0, pres, drho_dT, drho_dS, tv%eqn_of_state, US=US) do k=1,nz ; T0(k) = T0(k) + (GV%Rlay(k)-rho_guess(k)) / drho_dT(k) ; enddo enddo diff --git a/src/user/benchmark_initialization.F90 b/src/user/benchmark_initialization.F90 index 766474b364..ff76654b28 100644 --- a/src/user/benchmark_initialization.F90 +++ b/src/user/benchmark_initialization.F90 @@ -153,7 +153,7 @@ subroutine benchmark_initialize_thickness(h, G, GV, US, param_file, eqn_of_state enddo T0(k1) = 29.0 call calculate_density(T0(k1), S0(k1), pres(k1), rho_guess(k1), eqn_of_state, US=US) - call calculate_density_derivs(T0, S0, pres, drho_dT, drho_dS, k1, 1, eqn_of_state, US=US) + call calculate_density_derivs(T0(k1), S0(k1), pres(k1), drho_dT(k1), drho_dS(k1), eqn_of_state, US=US) ! A first guess of the layers' temperatures. do k=1,nz @@ -267,8 +267,8 @@ subroutine benchmark_init_temperature_salinity(T, S, G, GV, US, param_file, & ! Refine the guesses for each layer. ! do itt = 1,6 - call calculate_density(T0, S0, pres, rho_guess, 1, nz, eqn_of_state, US=US) - call calculate_density_derivs(T0, S0, pres, drho_dT, drho_dS, 1, nz, eqn_of_state, US=US) + call calculate_density(T0, S0, pres, rho_guess, eqn_of_state, US=US) + call calculate_density_derivs(T0, S0, pres, drho_dT, drho_dS, eqn_of_state, US=US) do k=1,nz T0(k) = T0(k) + (GV%Rlay(k) - rho_guess(k)) / drho_dT(k) enddo From 18d520e3c0da50955c9f0276c708c67bdb97952e Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Fri, 17 Apr 2020 17:16:49 +0000 Subject: [PATCH 204/316] Remove optional US from most MOM_EOS functions - Removes US as an argument wherever it was optional since the unit conversion factors are not stored in the EOS type. --- src/ALE/MOM_regridding.F90 | 6 +- src/ALE/coord_hycom.F90 | 6 +- src/ALE/coord_rho.F90 | 11 +- src/ALE/coord_slight.F90 | 12 +- src/core/MOM.F90 | 2 +- src/core/MOM_PressureForce_Montgomery.F90 | 20 +- src/core/MOM_PressureForce_analytic_FV.F90 | 22 +-- src/core/MOM_PressureForce_blocked_AFV.F90 | 18 +- src/core/MOM_forcing_type.F90 | 2 +- src/core/MOM_interface_heights.F90 | 4 +- src/core/MOM_isopycnal_slopes.F90 | 4 +- src/diagnostics/MOM_diagnostics.F90 | 12 +- src/diagnostics/MOM_wave_speed.F90 | 4 +- src/diagnostics/MOM_wave_structure.F90 | 2 +- src/equation_of_state/MOM_EOS.F90 | 178 +++++++----------- src/framework/MOM_diag_remap.F90 | 2 +- src/ice_shelf/MOM_ice_shelf.F90 | 4 +- .../MOM_coord_initialization.F90 | 6 +- .../MOM_state_initialization.F90 | 24 +-- .../lateral/MOM_mixed_layer_restrat.F90 | 8 +- .../lateral/MOM_thickness_diffuse.F90 | 8 +- .../vertical/MOM_bulk_mixed_layer.F90 | 8 +- .../vertical/MOM_diabatic_aux.F90 | 16 +- .../vertical/MOM_diabatic_driver.F90 | 2 +- .../vertical/MOM_diapyc_energy_req.F90 | 6 +- .../vertical/MOM_entrain_diffusive.F90 | 8 +- .../vertical/MOM_full_convection.F90 | 6 +- .../vertical/MOM_geothermal.F90 | 6 +- .../vertical/MOM_internal_tide_input.F90 | 2 +- .../vertical/MOM_kappa_shear.F90 | 2 +- .../vertical/MOM_regularize_layers.F90 | 4 +- .../vertical/MOM_set_diffusivity.F90 | 10 +- .../vertical/MOM_set_viscosity.F90 | 12 +- src/tracer/MOM_neutral_diffusion.F90 | 20 +- src/tracer/MOM_tracer_Z_init.F90 | 8 +- src/tracer/MOM_tracer_hor_diff.F90 | 2 +- src/user/DOME_initialization.F90 | 8 +- src/user/ISOMIP_initialization.F90 | 12 +- src/user/RGC_initialization.F90 | 2 +- src/user/benchmark_initialization.F90 | 16 +- src/user/user_change_diffusivity.F90 | 4 +- 41 files changed, 231 insertions(+), 278 deletions(-) diff --git a/src/ALE/MOM_regridding.F90 b/src/ALE/MOM_regridding.F90 index 1000ba0d32..5ef65342e5 100644 --- a/src/ALE/MOM_regridding.F90 +++ b/src/ALE/MOM_regridding.F90 @@ -1386,7 +1386,7 @@ subroutine build_rho_grid( G, GV, US, h, tv, dzInterface, remapCS, CS ) ! Local depth (G%bathyT is positive) nominalDepth = G%bathyT(i,j)*GV%Z_to_H - call build_rho_column(CS%rho_CS, US, nz, nominalDepth, h(i, j, :), & + call build_rho_column(CS%rho_CS, nz, nominalDepth, h(i, j, :), & tv%T(i, j, :), tv%S(i, j, :), tv%eqn_of_state, zNew, & h_neglect=h_neglect, h_neglect_edge=h_neglect_edge) @@ -1501,7 +1501,7 @@ subroutine build_grid_HyCOM1( G, GV, US, h, tv, h_new, dzInterface, CS ) ( 0.5 * ( z_col(K) + z_col(K+1) ) * (GV%H_to_RZ*GV%g_Earth) - tv%P_Ref ) enddo - call build_hycom1_column(CS%hycom_CS, US, tv%eqn_of_state, GV%ke, 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%Z_to_H, & h_neglect=h_neglect, h_neglect_edge=h_neglect_edge) @@ -1635,7 +1635,7 @@ subroutine build_grid_SLight(G, GV, US, h, tv, dzInterface, CS) ( 0.5 * ( z_col(K) + z_col(K+1) ) * (GV%H_to_RZ*GV%g_Earth) - tv%P_Ref ) enddo - call build_slight_column(CS%slight_CS, US, tv%eqn_of_state, GV%H_to_RZ*GV%g_Earth, & + call build_slight_column(CS%slight_CS, tv%eqn_of_state, GV%H_to_RZ*GV%g_Earth, & GV%H_subroundoff, nz, depth, h(i, j, :), & tv%T(i, j, :), tv%S(i, j, :), p_col, z_col, z_col_new, & h_neglect=h_neglect, h_neglect_edge=h_neglect_edge) diff --git a/src/ALE/coord_hycom.F90 b/src/ALE/coord_hycom.F90 index bfcff9005c..064860301d 100644 --- a/src/ALE/coord_hycom.F90 +++ b/src/ALE/coord_hycom.F90 @@ -4,7 +4,6 @@ module coord_hycom ! This file is part of MOM6. See LICENSE.md for the license. use MOM_error_handler, only : MOM_error, FATAL -use MOM_unit_scaling, only : unit_scale_type use MOM_EOS, only : EOS_type, calculate_density use regrid_interp, only : interp_CS_type, build_and_interpolate_grid @@ -96,10 +95,9 @@ subroutine set_hycom_params(CS, max_interface_depths, max_layer_thickness, inter end subroutine set_hycom_params !> Build a HyCOM coordinate column -subroutine build_hycom1_column(CS, US, eqn_of_state, nz, depth, h, T, S, p_col, & +subroutine build_hycom1_column(CS, eqn_of_state, nz, depth, h, T, S, p_col, & z_col, z_col_new, zScale, h_neglect, h_neglect_edge) type(hycom_CS), intent(in) :: CS !< Coordinate control structure - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type 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 [H ~> m or kg m-2]) @@ -133,7 +131,7 @@ subroutine build_hycom1_column(CS, US, eqn_of_state, nz, depth, h, T, S, p_col, z_scale = 1.0 ; if (present(zScale)) z_scale = zScale ! Work bottom recording potential density - call calculate_density(T, S, p_col, rho_col, 1, nz, eqn_of_state, US=US) + call calculate_density(T, S, p_col, rho_col, 1, nz, eqn_of_state) ! This ensures the potential density profile is monotonic ! although not necessarily single valued. do k = nz-1, 1, -1 diff --git a/src/ALE/coord_rho.F90 b/src/ALE/coord_rho.F90 index 565656ecb0..0da2a33554 100644 --- a/src/ALE/coord_rho.F90 +++ b/src/ALE/coord_rho.F90 @@ -5,7 +5,6 @@ module coord_rho use MOM_error_handler, only : MOM_error, FATAL use MOM_remapping, only : remapping_CS, remapping_core_h -use MOM_unit_scaling, only : unit_scale_type use MOM_EOS, only : EOS_type, calculate_density use regrid_interp, only : interp_CS_type, build_and_interpolate_grid, DEGREE_MAX @@ -88,10 +87,9 @@ end subroutine set_rho_params !! !! 1. Density profiles are calculated on the source grid. !! 2. Positions of target densities (for interfaces) are found by interpolation. -subroutine build_rho_column(CS, US, nz, depth, h, T, S, eqn_of_state, z_interface, & +subroutine build_rho_column(CS, nz, depth, h, T, S, eqn_of_state, z_interface, & h_neglect, h_neglect_edge) type(rho_CS), intent(in) :: CS !< coord_rho control structure - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type integer, intent(in) :: nz !< Number of levels on source grid (i.e. length of h, T, S) real, intent(in) :: depth !< Depth of ocean bottom (positive in m) real, dimension(nz), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] @@ -126,7 +124,7 @@ subroutine build_rho_column(CS, US, nz, depth, h, T, S, eqn_of_state, z_interfac ! Compute densities on source column pres(:) = CS%ref_pressure - call calculate_density(T, S, pres, densities, 1, nz, eqn_of_state, US=US) + call calculate_density(T, S, pres, densities, 1, nz, eqn_of_state) do k = 1,count_nonzero_layers densities(k) = densities(mapping(k)) enddo @@ -185,10 +183,9 @@ end subroutine build_rho_column !! 4. T & S are remapped onto the new grid. !! 5. Return to step 1 until convergence or until the maximum number of !! iterations is reached, whichever comes first. -subroutine build_rho_column_iteratively(CS, US, remapCS, nz, depth, h, T, S, eqn_of_state, & +subroutine build_rho_column_iteratively(CS, remapCS, nz, depth, h, T, S, eqn_of_state, & zInterface, h_neglect, h_neglect_edge, dev_tol) type(rho_CS), intent(in) :: CS !< Regridding control structure - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(remapping_CS), intent(in) :: remapCS !< Remapping parameters and options integer, intent(in) :: nz !< Number of levels real, intent(in) :: depth !< Depth of ocean bottom [Z ~> m] @@ -250,7 +247,7 @@ subroutine build_rho_column_iteratively(CS, US, remapCS, nz, depth, h, T, S, eqn enddo ! Compute densities within current water column - call calculate_density( T_tmp, S_tmp, pres, densities, 1, nz, eqn_of_state, US=US) + call calculate_density( T_tmp, S_tmp, pres, densities, 1, nz, eqn_of_state) do k = 1,count_nonzero_layers densities(k) = densities(mapping(k)) diff --git a/src/ALE/coord_slight.F90 b/src/ALE/coord_slight.F90 index 000315bae8..409b78c37c 100644 --- a/src/ALE/coord_slight.F90 +++ b/src/ALE/coord_slight.F90 @@ -4,7 +4,6 @@ module coord_slight ! This file is part of MOM6. See LICENSE.md for the license. use MOM_error_handler, only : MOM_error, FATAL -use MOM_unit_scaling, only : unit_scale_type use MOM_EOS, only : EOS_type, calculate_compress use MOM_EOS, only : calculate_density, calculate_density_derivs use regrid_interp, only : interp_CS_type, regridding_set_ppolys @@ -178,11 +177,10 @@ subroutine set_slight_params(CS, max_interface_depths, max_layer_thickness, & end subroutine set_slight_params !> Build a SLight coordinate column -subroutine build_slight_column(CS, US, eqn_of_state, H_to_pres, H_subroundoff, & +subroutine build_slight_column(CS, eqn_of_state, H_to_pres, H_subroundoff, & nz, depth, h_col, T_col, S_col, p_col, z_col, z_col_new, & h_neglect, h_neglect_edge) type(slight_CS), intent(in) :: CS !< Coordinate control structure - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(EOS_type), pointer :: eqn_of_state !< Equation of state structure real, intent(in) :: H_to_pres !< A conversion factor from thicknesses to !! scaled pressure [R L2 T-2 H-1 ~> Pa m-1 or Pa m2 kg-1] @@ -253,7 +251,7 @@ subroutine build_slight_column(CS, US, eqn_of_state, H_to_pres, H_subroundoff, & dz = (z_col(nz+1) - z_col(1)) / real(nz) do K=2,nz ; z_col_new(K) = z_col(1) + dz*real(K-1) ; enddo else - call calculate_density(T_col, S_col, p_col, rho_col, 1, nz, eqn_of_state, US=US) + call calculate_density(T_col, S_col, p_col, rho_col, 1, nz, eqn_of_state) ! Find the locations of the target potential densities, flagging ! locations in apparently unstable regions as not reliable. @@ -375,11 +373,11 @@ subroutine build_slight_column(CS, US, eqn_of_state, H_to_pres, H_subroundoff, & T_int(nz+1) = T_f(nz) ; S_int(nz+1) = S_f(nz) p_IS(nz+1) = z_col(nz+1) * H_to_pres call calculate_density_derivs(T_int, S_int, p_IS, drhoIS_dT, drhoIS_dS, 2, nz-1, & - eqn_of_state, US) + eqn_of_state) call calculate_density_derivs(T_int, S_int, p_R, drhoR_dT, drhoR_dS, 2, nz-1, & - eqn_of_state, US) + eqn_of_state) if (CS%compressibility_fraction > 0.0) then - call calculate_compress(T_int, S_int, p_R(:), rho_tmp, drho_dp, 2, nz-1, eqn_of_state, US) + call calculate_compress(T_int, S_int, p_R(:), rho_tmp, drho_dp, 2, nz-1, eqn_of_state) else do K=2,nz ; drho_dp(K) = 0.0 ; enddo endif diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index f07fd6a1c4..f25b8792f9 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -2905,7 +2905,7 @@ subroutine adjust_ssh_for_p_atm(tv, G, GV, US, ssh, p_atm, use_EOS) do j=js,je if (calc_rho) then call calculate_density(tv%T(:,j,1), tv%S(:,j,1), 0.5*p_atm(:,j), Rho_conv, G%HI, & - tv%eqn_of_state, US) + tv%eqn_of_state) do i=is,ie IgR0 = US%Z_to_m / (Rho_conv(i) * GV%g_Earth) ssh(i,j) = ssh(i,j) + p_atm(i,j) * IgR0 diff --git a/src/core/MOM_PressureForce_Montgomery.F90 b/src/core/MOM_PressureForce_Montgomery.F90 index 0d8cf27dad..c8e94ca7d8 100644 --- a/src/core/MOM_PressureForce_Montgomery.F90 +++ b/src/core/MOM_PressureForce_Montgomery.F90 @@ -187,7 +187,7 @@ subroutine PressureForce_Mont_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, pb !$OMP parallel do default(shared) do k=1,nz call int_specific_vol_dp(tv%T(:,:,k), tv%S(:,:,k), p(:,:,k), p(:,:,k+1), & - 0.0, G%HI, tv%eqn_of_state, dz_geo(:,:,k), halo_size=1, US=US) + 0.0, G%HI, tv%eqn_of_state, dz_geo(:,:,k), halo_size=1) enddo !$OMP parallel do default(shared) do j=Jsq,Jeq+1 ; do k=1,nz ; do i=Isq,Ieq+1 @@ -229,7 +229,7 @@ subroutine PressureForce_Mont_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, pb 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(:), start, npts, & - tv%eqn_of_state, US=US) + 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) @@ -246,7 +246,7 @@ subroutine PressureForce_Mont_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, pb !$OMP parallel do default(shared) private(rho_in_situ) do k=1,nz ; do j=Jsq,Jeq+1 call calculate_density(tv_tmp%T(:,j,k), tv_tmp%S(:,j,k), p_ref, rho_in_situ, start, npts, & - tv%eqn_of_state, US=US) + tv%eqn_of_state) do i=Isq,Ieq+1 ; alpha_star(i,j,k) = 1.0 / rho_in_situ(i) ; enddo enddo ; enddo endif ! use_EOS @@ -485,7 +485,7 @@ subroutine PressureForce_Mont_Bouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, pbce, 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(:), start, npts, & - tv%eqn_of_state, US=US) + tv%eqn_of_state) do k=nkmb+1,nz ; do i=Isq,Ieq+1 if (GV%Rlay(k) < Rho_cv_BL(i)) then @@ -506,7 +506,7 @@ subroutine PressureForce_Mont_Bouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, pbce, !$OMP parallel do default(shared) do k=1,nz+1 ; do j=Jsq,Jeq+1 call calculate_density(tv_tmp%T(:,j,k), tv_tmp%S(:,j,k), p_ref, rho_star(:,j,k), start, npts, & - tv%eqn_of_state, US=US) + tv%eqn_of_state) do i=Isq,Ieq+1 ; rho_star(i,j,k) = G_Rho0*rho_star(i,j,k) ; enddo enddo ; enddo endif ! use_EOS @@ -663,7 +663,7 @@ subroutine Set_pbce_Bouss(e, tv, G, GV, US, Rho0, GFS_scale, pbce, rho_star) press(i) = -Rho0xG*e(i,j,1) enddo call calculate_density(tv%T(:,j,1), tv%S(:,j,1), press, rho_in_situ, start, npts, & - tv%eqn_of_state, US=US) + tv%eqn_of_state) do i=Isq,Ieq+1 pbce(i,j,1) = G_Rho0*(GFS_scale * rho_in_situ(i)) * GV%H_to_Z enddo @@ -674,7 +674,7 @@ subroutine Set_pbce_Bouss(e, tv, G, GV, US, Rho0, GFS_scale, pbce, rho_star) S_int(i) = 0.5*(tv%S(i,j,k-1)+tv%S(i,j,k)) enddo call calculate_density_derivs(T_int, S_int, press, dR_dT, dR_dS, start, npts, & - tv%eqn_of_state, US=US) + tv%eqn_of_state) do i=Isq,Ieq+1 pbce(i,j,k) = pbce(i,j,k-1) + G_Rho0 * & ((e(i,j,K) - e(i,j,nz+1)) * Ihtot(i)) * & @@ -760,7 +760,7 @@ subroutine Set_pbce_nonBouss(p, tv, G, GV, US, GFS_scale, pbce, alpha_star) !$OMP parallel do default(shared) private(T_int,S_int,dR_dT,dR_dS,rho_in_situ) do j=Jsq,Jeq+1 call calculate_density(tv%T(:,j,nz), tv%S(:,j,nz), p(:,j,nz+1), rho_in_situ, start, npts, & - tv%eqn_of_state, US=US) + tv%eqn_of_state) do i=Isq,Ieq+1 C_htot(i,j) = dP_dH / ((p(i,j,nz+1)-p(i,j,1)) + dp_neglect) pbce(i,j,nz) = dP_dH / (rho_in_situ(i)) @@ -770,9 +770,9 @@ subroutine Set_pbce_nonBouss(p, tv, G, GV, US, GFS_scale, pbce, alpha_star) T_int(i) = 0.5*(tv%T(i,j,k)+tv%T(i,j,k+1)) S_int(i) = 0.5*(tv%S(i,j,k)+tv%S(i,j,k+1)) enddo - call calculate_density(T_int, S_int, p(:,j,k+1), rho_in_situ, start, npts, tv%eqn_of_state, US=US) + call calculate_density(T_int, S_int, p(:,j,k+1), rho_in_situ, start, npts, tv%eqn_of_state) call calculate_density_derivs(T_int, S_int, p(:,j,k+1), dR_dT, dR_dS, start, npts, & - tv%eqn_of_state, US=US) + tv%eqn_of_state) do i=Isq,Ieq+1 pbce(i,j,k) = pbce(i,j,k+1) + ((p(i,j,K+1)-p(i,j,1))*C_htot(i,j)) * & ((dR_dT(i)*(tv%T(i,j,k+1)-tv%T(i,j,k)) + & diff --git a/src/core/MOM_PressureForce_analytic_FV.F90 b/src/core/MOM_PressureForce_analytic_FV.F90 index f0a4485399..bb5af350cb 100644 --- a/src/core/MOM_PressureForce_analytic_FV.F90 +++ b/src/core/MOM_PressureForce_analytic_FV.F90 @@ -229,7 +229,7 @@ subroutine PressureForce_AFV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p 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(:), start, npts, & - tv%eqn_of_state, US=US) + 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) @@ -266,21 +266,21 @@ subroutine PressureForce_AFV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p 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, US=US) + useMassWghtInterp=CS%useMassWghtInterp) 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), US=US) + ! 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), bathyP=p(:,:,nz+1), dP_tiny=dp_neglect, & - useMassWghtInterp=CS%useMassWghtInterp, US=US) + useMassWghtInterp=CS%useMassWghtInterp) endif else alpha_anom = 1.0 / GV%Rlay(k) - alpha_ref @@ -335,7 +335,7 @@ subroutine PressureForce_AFV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p !$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, start, npts, & - tv%eqn_of_state, US=US) + 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)) @@ -579,7 +579,7 @@ subroutine PressureForce_AFV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_at 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(:), start, npts, & - tv%eqn_of_state, US=US) + tv%eqn_of_state) do k=nkmb+1,nz ; do i=Isq,Ieq+1 if (GV%Rlay(k) < Rho_cv_BL(i)) then @@ -602,10 +602,10 @@ subroutine PressureForce_AFV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_at 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, start, npts, & - tv%eqn_of_state, US=US) + tv%eqn_of_state) else call calculate_density(tv_tmp%T(:,j,1), tv_tmp%S(:,j,1), p0, rho_in_situ, start, npts, & - tv%eqn_of_state, US=US) + 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) @@ -670,17 +670,17 @@ subroutine PressureForce_AFV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_at 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, US=US) + 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, US=US) + intz_dpa, intx_dpa, inty_dpa) 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%HI, tv%eqn_of_state, dpa, & - intz_dpa, intx_dpa, inty_dpa, G%bathyT, dz_neglect, CS%useMassWghtInterp, US=US) + intz_dpa, intx_dpa, inty_dpa, G%bathyT, dz_neglect, CS%useMassWghtInterp) endif !$OMP parallel do default(shared) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 diff --git a/src/core/MOM_PressureForce_blocked_AFV.F90 b/src/core/MOM_PressureForce_blocked_AFV.F90 index 5ac7831479..9c04ad9684 100644 --- a/src/core/MOM_PressureForce_blocked_AFV.F90 +++ b/src/core/MOM_PressureForce_blocked_AFV.F90 @@ -225,7 +225,7 @@ subroutine PressureForce_blk_AFV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, 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(:), start, npts, & - tv%eqn_of_state, US=US) + 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) @@ -249,7 +249,7 @@ subroutine PressureForce_blk_AFV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, 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, US=US) + useMassWghtInterp=CS%useMassWghtInterp) else alpha_anom = 1.0 / GV%Rlay(k) - alpha_ref do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 @@ -303,7 +303,7 @@ subroutine PressureForce_blk_AFV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, !$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, start, npts, & - tv%eqn_of_state, US=US) + 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)) @@ -566,7 +566,7 @@ subroutine PressureForce_blk_AFV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, 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(:), start, npts, & - tv%eqn_of_state, US=US) + tv%eqn_of_state) do k=nkmb+1,nz ; do i=Isq,Ieq+1 if (GV%Rlay(k) < Rho_cv_BL(i)) then @@ -589,10 +589,10 @@ subroutine PressureForce_blk_AFV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, 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, start, npts, & - tv%eqn_of_state, US=US) + tv%eqn_of_state) else call calculate_density(tv_tmp%T(:,j,1), tv_tmp%S(:,j,1), p0, rho_in_situ, start, npts, & - tv%eqn_of_state, US=US) + 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) @@ -670,18 +670,18 @@ subroutine PressureForce_blk_AFV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, 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, US=US) + 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, US=US) + 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, US=US) + 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%Z_to_H diff --git a/src/core/MOM_forcing_type.F90 b/src/core/MOM_forcing_type.F90 index 12f165372b..d5a1fe3c79 100644 --- a/src/core/MOM_forcing_type.F90 +++ b/src/core/MOM_forcing_type.F90 @@ -954,7 +954,7 @@ subroutine calculateBuoyancyFlux1d(G, GV, US, fluxes, optics, nsw, h, Temp, Salt ! Density derivatives call calculate_density_derivs(Temp(:,j,1), Salt(:,j,1), pressure, dRhodT, dRhodS, G%HI, & - tv%eqn_of_state, US) + tv%eqn_of_state) ! Adjust netSalt to reflect dilution effect of FW flux netSalt(G%isc:G%iec) = netSalt(G%isc:G%iec) - Salt(G%isc:G%iec,j,1) * netH(G%isc:G%iec) ! ppt H/s diff --git a/src/core/MOM_interface_heights.F90 b/src/core/MOM_interface_heights.F90 index bfb9ad2703..ea529d42c5 100644 --- a/src/core/MOM_interface_heights.F90 +++ b/src/core/MOM_interface_heights.F90 @@ -106,7 +106,7 @@ subroutine find_eta_3d(h, tv, G, GV, US, eta, eta_bt, halo_size, eta_to_m) !$OMP do do k=1,nz call int_specific_vol_dp(tv%T(:,:,k), tv%S(:,:,k), p(:,:,K), p(:,:,K+1), & - 0.0, G%HI, tv%eqn_of_state, dz_geo(:,:,k), halo_size=halo, US=US) + 0.0, G%HI, tv%eqn_of_state, dz_geo(:,:,k), halo_size=halo) enddo !$OMP do do j=jsv,jev @@ -208,7 +208,7 @@ subroutine find_eta_2d(h, tv, G, GV, US, eta, eta_bt, halo_size, eta_to_m) !$OMP do do k = 1, nz call int_specific_vol_dp(tv%T(:,:,k), tv%S(:,:,k), p(:,:,k), p(:,:,k+1), 0.0, & - G%HI, tv%eqn_of_state, dz_geo(:,:,k), halo_size=halo, US=US) + G%HI, tv%eqn_of_state, dz_geo(:,:,k), halo_size=halo) enddo !$OMP do do j=js,je ; do k=1,nz ; do i=is,ie diff --git a/src/core/MOM_isopycnal_slopes.F90 b/src/core/MOM_isopycnal_slopes.F90 index 78fdc51077..6cb7e049a6 100644 --- a/src/core/MOM_isopycnal_slopes.F90 +++ b/src/core/MOM_isopycnal_slopes.F90 @@ -176,7 +176,7 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, & S_u(I) = 0.25*((S(i,j,k) + S(i+1,j,k)) + (S(i,j,k-1) + S(i+1,j,k-1))) enddo call calculate_density_derivs(T_u, S_u, pres_u, drho_dT_u, drho_dS_u, (is-IsdB+1)-1, ie-is+2, & - tv%eqn_of_state, US=US) + tv%eqn_of_state) endif do I=is-1,ie @@ -262,7 +262,7 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, & S_v(i) = 0.25*((S(i,j,k) + S(i,j+1,k)) + (S(i,j,k-1) + S(i,j+1,k-1))) enddo call calculate_density_derivs(T_v, S_v, pres_v, drho_dT_v, drho_dS_v, is, ie-is+1, & - tv%eqn_of_state, US=US) + tv%eqn_of_state) endif do i=is,ie if (use_EOS) then diff --git a/src/diagnostics/MOM_diagnostics.F90 b/src/diagnostics/MOM_diagnostics.F90 index 94f6acc9c3..d653ddec6c 100644 --- a/src/diagnostics/MOM_diagnostics.F90 +++ b/src/diagnostics/MOM_diagnostics.F90 @@ -360,7 +360,7 @@ subroutine calculate_diagnostic_fields(u, v, h, uh, vh, tv, ADp, CDp, p_surf, & enddo ! Store in-situ density [R ~> kg m-3] in work_3d call calculate_density(tv%T(:,j,k), tv%S(:,j,k), pressure_1d, rho_in_situ, G%HI, & - tv%eqn_of_state, US) + tv%eqn_of_state) do i=is,ie ! Cell thickness = dz = dp/(g*rho) (meter); store in work_3d work_3d(i,j,k) = (GV%H_to_RZ*h(i,j,k)) / rho_in_situ(i) enddo @@ -466,7 +466,7 @@ subroutine calculate_diagnostic_fields(u, v, h, uh, vh, tv, ADp, CDp, p_surf, & !$OMP parallel do default(shared) do k=1,nz ; do j=js-1,je+1 call calculate_density(tv%T(:,j,k), tv%S(:,j,k), pressure_1d, Rcv(:,j,k), G%HI, & - tv%eqn_of_state, US, halo=1) + tv%eqn_of_state, halo=1) enddo ; enddo else ! Rcv should not be used much in this case, so fill in sensible values. do k=1,nz ; do j=js-1,je+1 ; do i=is-1,ie+1 @@ -588,7 +588,7 @@ subroutine calculate_diagnostic_fields(u, v, h, uh, vh, tv, ADp, CDp, p_surf, & pressure_1d(:) = 0. !$OMP parallel do default(shared) do k=1,nz ; do j=js,je - call calculate_density(tv%T(:,j,k), tv%S(:,j,k), pressure_1d, Rcv(:,j,k), G%HI, tv%eqn_of_state, US) + call calculate_density(tv%T(:,j,k), tv%S(:,j,k), pressure_1d, Rcv(:,j,k), G%HI, tv%eqn_of_state) enddo ; enddo if (CS%id_rhopot0 > 0) call post_data(CS%id_rhopot0, Rcv, CS%diag) endif @@ -596,7 +596,7 @@ subroutine calculate_diagnostic_fields(u, v, h, uh, vh, tv, ADp, CDp, p_surf, & pressure_1d(:) = 2.0e7*US%kg_m3_to_R*US%m_s_to_L_T**2 ! 2000 dbars !$OMP parallel do default(shared) do k=1,nz ; do j=js,je - call calculate_density(tv%T(:,j,k), tv%S(:,j,k), pressure_1d, Rcv(:,j,k), G%HI, tv%eqn_of_state, US) + call calculate_density(tv%T(:,j,k), tv%S(:,j,k), pressure_1d, Rcv(:,j,k), G%HI, tv%eqn_of_state) enddo ; enddo if (CS%id_rhopot2 > 0) call post_data(CS%id_rhopot2, Rcv, CS%diag) endif @@ -606,7 +606,7 @@ subroutine calculate_diagnostic_fields(u, v, h, uh, vh, tv, ADp, CDp, p_surf, & pressure_1d(:) = 0. ! Start at p=0 Pa at surface do k=1,nz pressure_1d(:) = pressure_1d(:) + 0.5 * h(:,j,k) * (GV%H_to_RZ*GV%g_Earth) ! Pressure in middle of layer k - call calculate_density(tv%T(:,j,k), tv%S(:,j,k), pressure_1d, Rcv(:,j,k), G%HI, tv%eqn_of_state, US) + call calculate_density(tv%T(:,j,k), tv%S(:,j,k), pressure_1d, Rcv(:,j,k), G%HI, tv%eqn_of_state) pressure_1d(:) = pressure_1d(:) + 0.5 * h(:,j,k) * (GV%H_to_RZ*GV%g_Earth) ! Pressure at bottom of layer k enddo enddo @@ -839,7 +839,7 @@ subroutine calculate_vertical_integrals(h, tv, p_surf, G, GV, US, CS) z_bot(i,j) = z_top(i,j) - GV%H_to_Z*h(i,j,k) enddo ; enddo call int_density_dz(tv%T(:,:,k), tv%S(:,:,k), z_top, z_bot, 0.0, GV%Rho0, GV%g_Earth, & - G%HI, G%HI, tv%eqn_of_state, dpress, US=US) + G%HI, G%HI, tv%eqn_of_state, dpress) do j=js,je ; do i=is,ie mass(i,j) = mass(i,j) + dpress(i,j) * IG_Earth enddo ; enddo diff --git a/src/diagnostics/MOM_wave_speed.F90 b/src/diagnostics/MOM_wave_speed.F90 index 85dbcdc13b..ce36835c1a 100644 --- a/src/diagnostics/MOM_wave_speed.F90 +++ b/src/diagnostics/MOM_wave_speed.F90 @@ -243,7 +243,7 @@ subroutine wave_speed(h, tv, G, GV, US, cg1, CS, full_halos, use_ebt_mode, & S_int(k) = 0.5*(Sf(k,i)+Sf(k-1,i)) enddo call calculate_density_derivs(T_int, S_int, pres, drho_dT, drho_dS, 2, & - kf(i)-1, tv%eqn_of_state, US) + kf(i)-1, tv%eqn_of_state) ! Sum the reduced gravities to find out how small a density difference ! is negligibly small. @@ -738,7 +738,7 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, full_halos) S_int(k) = 0.5*(Sf(k,i)+Sf(k-1,i)) enddo call calculate_density_derivs(T_int, S_int, pres, drho_dT, drho_dS, 2, & - kf(i)-1, tv%eqn_of_state, US) + kf(i)-1, tv%eqn_of_state) ! Sum the reduced gravities to find out how small a density difference ! is negligibly small. diff --git a/src/diagnostics/MOM_wave_structure.F90 b/src/diagnostics/MOM_wave_structure.F90 index ceb6fd6c4f..69c5bcb44f 100644 --- a/src/diagnostics/MOM_wave_structure.F90 +++ b/src/diagnostics/MOM_wave_structure.F90 @@ -278,7 +278,7 @@ subroutine wave_structure(h, tv, G, GV, US, cn, ModeNum, freq, CS, En, full_halo S_int(k) = 0.5*(Sf(k,i)+Sf(k-1,i)) enddo call calculate_density_derivs(T_int, S_int, pres, drho_dT, drho_dS, 2, & - kf(i)-1, tv%eqn_of_state, US) + kf(i)-1, tv%eqn_of_state) ! Sum the reduced gravities to find out how small a density difference ! is negligibly small. diff --git a/src/equation_of_state/MOM_EOS.F90 b/src/equation_of_state/MOM_EOS.F90 index dc74e1dcf7..11763e066a 100644 --- a/src/equation_of_state/MOM_EOS.F90 +++ b/src/equation_of_state/MOM_EOS.F90 @@ -114,10 +114,11 @@ module MOM_EOS ! Unit conversion factors (normally used for dimensional testing but could also allow for ! change of units of arguments to functions) - real :: m_to_Z !< A constant that translates distances in meters to the units of depth. - real :: kg_m3_to_R !< A constant that translates kilograms per meter cubed to the units of density. - real :: R_to_kg_m3 !< A constant that translates the units of density to kilograms per meter cubed. - real :: RL2_T2_to_Pa !< Convert pressures from R L2 T-2 to Pa. + real :: m_to_Z !< A constant that translates distances in meters to the units of depth. + real :: kg_m3_to_R !< A constant that translates kilograms per meter cubed to the units of density. + real :: R_to_kg_m3 !< A constant that translates the units of density to kilograms per meter cubed. + real :: RL2_T2_to_Pa !< Convert pressures from R L2 T-2 to Pa. + real :: L_T_to_m_s !< Convert lateral velocities from L T-1 to m s-1. ! logical :: test_EOS = .true. ! If true, test the equation of state end type EOS_type @@ -151,14 +152,13 @@ module MOM_EOS !! If rho_ref is present, the anomaly with respect to rho_ref is returned. The pressure and !! density can be rescaled with the US. If both the US and scale arguments are present the density !! scaling uses the product of the two scaling factors. -subroutine calculate_density_scalar(T, S, pressure, rho, EOS, rho_ref, US, scale) +subroutine calculate_density_scalar(T, S, pressure, rho, EOS, rho_ref, scale) real, intent(in) :: T !< Potential temperature referenced to the surface [degC] real, intent(in) :: S !< Salinity [ppt] real, intent(in) :: pressure !< Pressure [Pa] or [R L2 T-2 ~> Pa] real, intent(out) :: rho !< Density (in-situ if pressure is local) [kg m-3] or [R ~> kg m-3] type(EOS_type), pointer :: EOS !< Equation of state structure real, optional, intent(in) :: rho_ref !< A reference density [kg m-3] - type(unit_scale_type), optional, intent(in) :: US !< A dimensional unit scaling type real, optional, intent(in) :: scale !< A multiplicative factor by which to scale density in !! combination with scaling given by US [various] @@ -168,7 +168,7 @@ subroutine calculate_density_scalar(T, S, pressure, rho, EOS, rho_ref, US, scale if (.not.associated(EOS)) call MOM_error(FATAL, & "calculate_density_scalar called with an unassociated EOS_type EOS.") - p_scale = 1.0 ; if (present(US)) p_scale = EOS%RL2_T2_to_Pa + p_scale = EOS%RL2_T2_to_Pa select case (EOS%form_of_EOS) case (EOS_LINEAR) @@ -186,17 +186,15 @@ subroutine calculate_density_scalar(T, S, pressure, rho, EOS, rho_ref, US, scale call MOM_error(FATAL, "calculate_density_scalar: EOS is not valid.") end select - if (present(US) .or. present(scale)) then - rho_scale = 1.0 ; if (present(US)) rho_scale = EOS%kg_m3_to_R - if (present(scale)) rho_scale = rho_scale * scale - rho = rho_scale * rho - endif + rho_scale = EOS%kg_m3_to_R + if (present(scale)) rho_scale = rho_scale * scale + rho = rho_scale * rho end subroutine calculate_density_scalar !> Calls the appropriate subroutine to calculate the density of sea water for 1-D array inputs. !! 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, US, scale) +subroutine calculate_density_array(T, S, pressure, rho, start, npts, EOS, rho_ref, scale) real, dimension(:), intent(in) :: T !< Potential temperature referenced to the surface [degC] real, dimension(:), intent(in) :: S !< Salinity [ppt] real, dimension(:), intent(in) :: pressure !< Pressure [Pa] or [R L2 T-2 ~> Pa] @@ -205,7 +203,6 @@ subroutine calculate_density_array(T, S, pressure, rho, start, npts, EOS, rho_re 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 [kg m-3] - type(unit_scale_type), optional, intent(in) :: US !< A dimensional unit scaling type real, optional, intent(in) :: scale !< A multiplicative factor by which to scale density !! in combination with scaling given by US [various] @@ -217,7 +214,7 @@ subroutine calculate_density_array(T, S, pressure, rho, start, npts, EOS, rho_re if (.not.associated(EOS)) call MOM_error(FATAL, & "calculate_density_array called with an unassociated EOS_type EOS.") - p_scale = 1.0 ; if (present(US)) p_scale = EOS%RL2_T2_to_Pa + p_scale = EOS%RL2_T2_to_Pa if (p_scale == 1.0) then select case (EOS%form_of_EOS) @@ -254,7 +251,7 @@ subroutine calculate_density_array(T, S, pressure, rho, start, npts, EOS, rho_re end select endif - rho_scale = 1.0 ; if (present(US)) rho_scale = EOS%kg_m3_to_R + rho_scale = EOS%kg_m3_to_R if (present(scale)) rho_scale = rho_scale * scale if (rho_scale /= 1.0) then do j=start,start+npts-1 ; rho(j) = rho_scale * rho(j) ; enddo @@ -265,14 +262,13 @@ end subroutine calculate_density_array !> Calls the appropriate subroutine to calculate the density of sea water for 1-D array inputs !! using array extents determined from a hor_index_type. !! If rho_ref is present, the anomaly with respect to rho_ref is returned. -subroutine calculate_density_HI_1d(T, S, pressure, rho, HI, EOS, US, halo) +subroutine calculate_density_HI_1d(T, S, pressure, rho, HI, EOS, halo) type(hor_index_type), intent(in) :: HI !< The horizontal index structure real, dimension(HI%isd:HI%ied), intent(in) :: T !< Potential temperature referenced to the surface [degC] real, dimension(HI%isd:HI%ied), intent(in) :: S !< Salinity [ppt] real, dimension(HI%isd:HI%ied), intent(in) :: pressure !< Pressure [R L2 T-2 ~> Pa] real, dimension(HI%isd:HI%ied), intent(inout) :: rho !< Density (in-situ if pressure is local) [R ~> kg m-3] type(EOS_type), pointer :: EOS !< Equation of state structure - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type integer, optional, intent(in) :: halo !< The halo size to work on; missing is equivalent to 0. ! Local variables @@ -350,14 +346,13 @@ end subroutine calculate_spec_vol_array !> Calls the appropriate subroutine to calculate specific volume of sea water !! for scalar inputs. -subroutine calc_spec_vol_scalar(T, S, pressure, specvol, EOS, spv_ref, US, scale) +subroutine calc_spec_vol_scalar(T, S, pressure, specvol, EOS, spv_ref, scale) real, intent(in) :: T !< Potential temperature referenced to the surface [degC] real, intent(in) :: S !< Salinity [ppt] real, intent(in) :: pressure !< Pressure [Pa] or [R L2 T-2 ~> Pa] real, intent(out) :: specvol !< In situ? specific volume [m3 kg-1] or [R-1 ~> m3 kg-1] type(EOS_type), pointer :: EOS !< Equation of state structure real, optional, intent(in) :: spv_ref !< A reference specific volume [m3 kg-1] or [R-1 m3 kg-1] - type(unit_scale_type), optional, intent(in) :: US !< A dimensional unit scaling type real, optional, intent(in) :: scale !< A multiplicative factor by which to scale specific !! volume in combination with scaling given by US [various] @@ -368,18 +363,18 @@ subroutine calc_spec_vol_scalar(T, S, pressure, specvol, EOS, spv_ref, US, scale if (.not.associated(EOS)) call MOM_error(FATAL, & "calc_spec_vol_scalar called with an unassociated EOS_type EOS.") - pres(1) = pressure ; if (present(US)) pres(1) = EOS%RL2_T2_to_Pa*pressure + pres(1) = EOS%RL2_T2_to_Pa*pressure Ta(1) = T ; Sa(1) = S if (present(spv_ref)) then - spv_reference = spv_ref ; if (present(US)) spv_reference = EOS%kg_m3_to_R*spv_ref + spv_reference = EOS%kg_m3_to_R*spv_ref call calculate_spec_vol_array(Ta, Sa, pres, spv, 1, 1, EOS, spv_reference) else call calculate_spec_vol_array(Ta, Sa, pres, spv, 1, 1, EOS) endif specvol = spv(1) - spv_scale = 1.0 ; if (present(US)) spv_scale = EOS%R_to_kg_m3 + spv_scale = EOS%R_to_kg_m3 if (present(scale)) spv_scale = spv_scale * scale if (spv_scale /= 1.0) then specvol = spv_scale * specvol @@ -436,14 +431,13 @@ end subroutine calc_spec_vol_US !> Calls the appropriate subroutine to calculate the specific volume of sea water for 1-D array !! inputs using array extents determined from a hor_index_type. -subroutine calc_spec_vol_HI_1d(T, S, pressure, specvol, HI, EOS, US, halo, spv_ref) +subroutine calc_spec_vol_HI_1d(T, S, pressure, specvol, HI, EOS, halo, spv_ref) type(hor_index_type), intent(in) :: HI !< The horizontal index structure real, dimension(HI%isd:HI%ied), intent(in) :: T !< Potential temperature referenced to the surface [degC] real, dimension(HI%isd:HI%ied), intent(in) :: S !< Salinity [ppt] real, dimension(HI%isd:HI%ied), intent(in) :: pressure !< Pressure [R L2 T-2 ~> Pa] real, dimension(HI%isd:HI%ied), intent(inout) :: specvol !< In situ specific volume [R-1 ~> m3 kg-1] type(EOS_type), pointer :: EOS !< Equation of state structure - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type integer, optional, intent(in) :: halo !< The halo size to work on; missing is equivalent to 0. real, optional, intent(in) :: spv_ref !< A reference specific volume [R-1 ~> m3 kg-1] @@ -561,7 +555,7 @@ subroutine calculate_TFreeze_array(S, pressure, T_fr, start, npts, EOS, pres_sca end subroutine calculate_TFreeze_array !> Calls the appropriate subroutine to calculate density derivatives for 1-D array inputs. -subroutine calculate_density_derivs_array(T, S, pressure, drho_dT, drho_dS, start, npts, EOS, US, scale) +subroutine calculate_density_derivs_array(T, S, pressure, drho_dT, drho_dS, start, npts, EOS, scale) real, dimension(:), intent(in) :: T !< Potential temperature referenced to the surface [degC] real, dimension(:), intent(in) :: S !< Salinity [ppt] real, dimension(:), intent(in) :: pressure !< Pressure [Pa] or [R L2 T-2 ~> Pa] @@ -572,7 +566,6 @@ subroutine calculate_density_derivs_array(T, S, pressure, drho_dT, drho_dS, star 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 - type(unit_scale_type), optional, intent(in) :: US !< A dimensional unit scaling type real, optional, intent(in) :: scale !< A multiplicative factor by which to scale density !! in combination with scaling given by US [various] @@ -585,7 +578,7 @@ subroutine calculate_density_derivs_array(T, S, pressure, drho_dT, drho_dS, star if (.not.associated(EOS)) call MOM_error(FATAL, & "calculate_density_derivs called with an unassociated EOS_type EOS.") - p_scale = 1.0 ; if (present(US)) p_scale = EOS%RL2_T2_to_Pa + p_scale = EOS%RL2_T2_to_Pa if (p_scale == 1.0) then select case (EOS%form_of_EOS) @@ -622,7 +615,7 @@ subroutine calculate_density_derivs_array(T, S, pressure, drho_dT, drho_dS, star end select endif - rho_scale = 1.0 ; if (present(US)) rho_scale = EOS%kg_m3_to_R + rho_scale = EOS%kg_m3_to_R if (present(scale)) rho_scale = rho_scale * scale if (rho_scale /= 1.0) then ; do j=start,start+npts-1 drho_dT(j) = rho_scale * drho_dT(j) @@ -633,7 +626,7 @@ end subroutine calculate_density_derivs_array !> Calls the appropriate subroutine to calculate density derivatives for 1-D array inputs. -subroutine calculate_density_derivs_HI_1d(T, S, pressure, drho_dT, drho_dS, HI, EOS, US, halo) +subroutine calculate_density_derivs_HI_1d(T, S, pressure, drho_dT, drho_dS, HI, EOS, halo) type(hor_index_type), intent(in) :: HI !< The horizontal index structure real, dimension(HI%isd:HI%ied), intent(in) :: T !< Potential temperature referenced to the surface [degC] real, dimension(HI%isd:HI%ied), intent(in) :: S !< Salinity [ppt] @@ -643,7 +636,6 @@ subroutine calculate_density_derivs_HI_1d(T, S, pressure, drho_dT, drho_dS, HI, real, dimension(HI%isd:HI%ied), intent(inout) :: drho_dS !< The partial derivative of density with salinity !! [R degC-1 ~> kg m-3 ppt-1] type(EOS_type), pointer :: EOS !< Equation of state structure - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type integer, optional, intent(in) :: halo !< The halo size to work on; missing is equivalent to 0. ! Local variables @@ -676,7 +668,7 @@ end subroutine calculate_density_derivs_HI_1d !> 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, US, scale) +subroutine calculate_density_derivs_scalar(T, S, pressure, drho_dT, drho_dS, EOS, scale) real, intent(in) :: T !< Potential temperature referenced to the surface [degC] real, intent(in) :: S !< Salinity [ppt] real, intent(in) :: pressure !< Pressure [Pa] or [R L2 T-2 ~> Pa] @@ -685,10 +677,8 @@ subroutine calculate_density_derivs_scalar(T, S, pressure, drho_dT, drho_dS, EOS real, intent(out) :: drho_dS !< The partial derivative of density with salinity, !! in [kg m-3 ppt-1] or [R ppt-1 ~> kg m-3 ppt-1] type(EOS_type), pointer :: EOS !< Equation of state structure - type(unit_scale_type), optional, intent(in) :: US !< A dimensional unit scaling type real, optional, intent(in) :: scale !< A multiplicative factor by which to scale density !! in combination with scaling given by US [various] - ! Local variables real :: rho_scale ! A factor to convert density from kg m-3 to the desired units [R m3 kg-1 ~> 1] real :: p_scale ! A factor to convert pressure to units of Pa [Pa T2 R-1 L-2 ~> 1] @@ -697,7 +687,7 @@ subroutine calculate_density_derivs_scalar(T, S, pressure, drho_dT, drho_dS, EOS if (.not.associated(EOS)) call MOM_error(FATAL, & "calculate_density_derivs called with an unassociated EOS_type EOS.") - p_scale = 1.0 ; if (present(US)) p_scale = EOS%RL2_T2_to_Pa + p_scale = EOS%RL2_T2_to_Pa select case (EOS%form_of_EOS) case (EOS_LINEAR) @@ -711,7 +701,7 @@ subroutine calculate_density_derivs_scalar(T, S, pressure, drho_dT, drho_dS, EOS call MOM_error(FATAL, "calculate_density_derivs_scalar: EOS%form_of_EOS is not valid.") end select - rho_scale = 1.0 ; if (present(US)) rho_scale = EOS%kg_m3_to_R + rho_scale = EOS%kg_m3_to_R if (present(scale)) rho_scale = rho_scale * scale if (rho_scale /= 1.0) then drho_dT = rho_scale * drho_dT @@ -722,7 +712,7 @@ 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, US, scale) + drho_dS_dP, drho_dT_dP, start, npts, EOS, scale) real, dimension(:), intent(in) :: T !< Potential temperature referenced to the surface [degC] real, dimension(:), intent(in) :: S !< Salinity [ppt] real, dimension(:), intent(in) :: pressure !< Pressure [Pa] or [R L2 T-2 ~> Pa] @@ -739,10 +729,8 @@ subroutine calculate_density_second_derivs_array(T, S, pressure, drho_dS_dS, drh 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 - type(unit_scale_type), optional, intent(in) :: US !< A dimensional unit scaling type real, optional, intent(in) :: scale !< A multiplicative factor by which to scale density !! in combination with scaling given by US [various] - ! Local variables real, dimension(size(pressure)) :: pres ! Pressure converted to [Pa] real :: rho_scale ! A factor to convert density from kg m-3 to the desired units [R m3 kg-1 ~> 1] @@ -753,7 +741,7 @@ subroutine calculate_density_second_derivs_array(T, S, pressure, drho_dS_dS, drh if (.not.associated(EOS)) call MOM_error(FATAL, & "calculate_density_derivs called with an unassociated EOS_type EOS.") - p_scale = 1.0 ; if (present(US)) p_scale = EOS%RL2_T2_to_Pa + p_scale = EOS%RL2_T2_to_Pa if (p_scale == 1.0) then select case (EOS%form_of_EOS) @@ -786,7 +774,7 @@ subroutine calculate_density_second_derivs_array(T, S, pressure, drho_dS_dS, drh end select endif - rho_scale = 1.0 ; if (present(US)) rho_scale = EOS%kg_m3_to_R + rho_scale = EOS%kg_m3_to_R if (present(scale)) rho_scale = rho_scale * scale if (rho_scale /= 1.0) then ; do j=start,start+npts-1 drho_dS_dS(j) = rho_scale * drho_dS_dS(j) @@ -808,7 +796,7 @@ 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, US, scale) + drho_dS_dP, drho_dT_dP, EOS, scale) real, intent(in) :: T !< Potential temperature referenced to the surface [degC] real, intent(in) :: S !< Salinity [ppt] real, intent(in) :: pressure !< Pressure [Pa] or [R L2 T-2 ~> Pa] @@ -823,7 +811,6 @@ subroutine calculate_density_second_derivs_scalar(T, S, pressure, drho_dS_dS, dr real, intent(out) :: drho_dT_dP !< Partial derivative of alpha with respect to pressure !! [kg m-3 degC-1 Pa-1] or [R degC-1 Pa-1 ~> kg m-3 degC-1 Pa-1] type(EOS_type), pointer :: EOS !< Equation of state structure - type(unit_scale_type), optional, intent(in) :: US !< A dimensional unit scaling type real, optional, intent(in) :: scale !< A multiplicative factor by which to scale density !! in combination with scaling given by US [various] ! Local variables @@ -834,7 +821,7 @@ subroutine calculate_density_second_derivs_scalar(T, S, pressure, drho_dS_dS, dr if (.not.associated(EOS)) call MOM_error(FATAL, & "calculate_density_derivs called with an unassociated EOS_type EOS.") - p_scale = 1.0 ; if (present(US)) p_scale = EOS%RL2_T2_to_Pa + p_scale = EOS%RL2_T2_to_Pa select case (EOS%form_of_EOS) case (EOS_LINEAR) @@ -850,7 +837,7 @@ subroutine calculate_density_second_derivs_scalar(T, S, pressure, drho_dS_dS, dr call MOM_error(FATAL, "calculate_density_derivs: EOS%form_of_EOS is not valid.") end select - rho_scale = 1.0 ; if (present(US)) rho_scale = EOS%kg_m3_to_R + rho_scale = EOS%kg_m3_to_R if (present(scale)) rho_scale = rho_scale * scale if (rho_scale /= 1.0) then drho_dS_dS = rho_scale * drho_dS_dS @@ -964,7 +951,7 @@ end subroutine calc_spec_vol_derivs_US !> Calls the appropriate subroutine to calculate specific volume derivatives for array inputs !! using array extents determined from a hor_index_type.. -subroutine calc_spec_vol_derivs_HI_1d(T, S, pressure, dSV_dT, dSV_dS, HI, EOS, US, halo) +subroutine calc_spec_vol_derivs_HI_1d(T, S, pressure, dSV_dT, dSV_dS, HI, EOS, halo) type(hor_index_type), intent(in) :: HI !< The horizontal index structure real, dimension(HI%isd:HI%ied), intent(in) :: T !< Potential temperature referenced to the surface [degC] real, dimension(HI%isd:HI%ied), intent(in) :: S !< Salinity [ppt] @@ -974,7 +961,6 @@ subroutine calc_spec_vol_derivs_HI_1d(T, S, pressure, dSV_dT, dSV_dS, HI, EOS, U real, dimension(HI%isd:HI%ied), intent(inout) :: dSV_dS !< The partial derivative of specific volume with salinity !! [R-1 ppt-1 ~> m3 kg-1 ppt-1] type(EOS_type), pointer :: EOS !< Equation of state structure - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type integer, optional, intent(in) :: halo !< The halo size to work on; missing is equivalent to 0. ! Local variables @@ -1007,7 +993,7 @@ end subroutine calc_spec_vol_derivs_HI_1d !> Calls the appropriate subroutine to calculate the density and compressibility for 1-D array !! inputs. If US is present, the units of the inputs and outputs are rescaled. -subroutine calculate_compress_array(T, S, press, rho, drho_dp, start, npts, EOS, US) +subroutine calculate_compress_array(T, S, press, rho, drho_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) :: press !< Pressure [Pa] or [R L2 T-2 ~> Pa] @@ -1018,7 +1004,6 @@ subroutine calculate_compress_array(T, S, press, rho, drho_dp, start, npts, EOS, 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 - type(unit_scale_type), optional, intent(in) :: US !< A dimensional unit scaling type ! Local variables real, dimension(size(press)) :: pressure ! Pressure converted to [Pa] @@ -1028,11 +1013,7 @@ subroutine calculate_compress_array(T, S, press, rho, drho_dp, start, npts, EOS, "calculate_compress called with an unassociated EOS_type EOS.") is = start ; ie = is + npts - 1 - if (present(US)) then - do i=is,ie ; pressure(i) = US%RL2_T2_to_Pa * press(i) ; enddo - else - do i=is,ie ; pressure(i) = press(i) ; enddo - endif + do i=is,ie ; pressure(i) = EOS%RL2_T2_to_Pa * press(i) ; enddo select case (EOS%form_of_EOS) case (EOS_LINEAR) @@ -1050,21 +1031,19 @@ subroutine calculate_compress_array(T, S, press, rho, drho_dp, start, npts, EOS, call MOM_error(FATAL, "calculate_compress: EOS%form_of_EOS is not valid.") end select - if (present(US)) then - if (US%kg_m3_to_R /= 1.0) then ; do i=is,ie - rho(i) = US%kg_m3_to_R * rho(i) - enddo ; endif - if (US%L_T_to_m_s /= 1.0) then ; do i=is,ie - drho_dp(i) = US%L_T_to_m_s**2 * drho_dp(i) - enddo ; endif - endif + if (EOS%kg_m3_to_R /= 1.0) then ; do i=is,ie + rho(i) = EOS%kg_m3_to_R * rho(i) + enddo ; endif + if (EOS%L_T_to_m_s /= 1.0) then ; do i=is,ie + drho_dp(i) = EOS%L_T_to_m_s**2 * drho_dp(i) + enddo ; endif end subroutine calculate_compress_array !> Calculate density and compressibility for a scalar. This just promotes the scalar to an array !! with a singleton dimension and calls calculate_compress_array. If US is present, the units of !! the inputs and outputs are rescaled. -subroutine calculate_compress_scalar(T, S, pressure, rho, drho_dp, EOS, US) +subroutine calculate_compress_scalar(T, S, pressure, rho, drho_dp, EOS) real, intent(in) :: T !< Potential temperature referenced to the surface [degC] real, intent(in) :: S !< Salinity [ppt] real, intent(in) :: pressure !< Pressure [Pa] or [R L2 T-2 ~> Pa] @@ -1072,7 +1051,6 @@ subroutine calculate_compress_scalar(T, S, pressure, rho, drho_dp, EOS, US) real, intent(out) :: drho_dp !< The partial derivative of density with pressure (also the !! inverse of the square of sound speed) [s2 m-2] or [T2 L-2] type(EOS_type), pointer :: EOS !< Equation of state structure - type(unit_scale_type), optional, intent(in) :: US !< A dimensional unit scaling type real, dimension(1) :: Ta, Sa, pa, rhoa, drho_dpa @@ -1080,7 +1058,7 @@ subroutine calculate_compress_scalar(T, S, pressure, rho, drho_dp, EOS, US) "calculate_compress called with an unassociated EOS_type EOS.") Ta(1) = T ; Sa(1) = S; pa(1) = pressure - call calculate_compress_array(Ta, Sa, pa, rhoa, drho_dpa, 1, 1, EOS, US) + call calculate_compress_array(Ta, Sa, pa, rhoa, drho_dpa, 1, 1, EOS) rho = rhoa(1) ; drho_dp = drho_dpa(1) end subroutine calculate_compress_scalar @@ -1094,7 +1072,7 @@ end subroutine calculate_compress_scalar !! 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, & - bathyP, dP_tiny, useMassWghtInterp, US) + bathyP, dP_tiny, useMassWghtInterp) type(hor_index_type), intent(in) :: HI !< The horizontal index structure real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & intent(in) :: T !< Potential temperature referenced to the surface [degC] @@ -1131,8 +1109,6 @@ subroutine int_specific_vol_dp(T, S, p_t, p_b, alpha_ref, HI, EOS, & !! the same units as p_t [R L2 T-2 ~> Pa] or [Pa] logical, optional, intent(in) :: useMassWghtInterp !< If true, uses mass weighting !! to interpolate T/S for top and bottom integrals. - type(unit_scale_type), optional, intent(in) :: US !< A dimensional unit scaling type - ! Local variables real :: pres_scale ! A unit conversion factor from the rescaled units of pressure to Pa [Pa T2 R-1 L-2 ~> 1] real :: SV_scale ! A multiplicative factor by which to scale specific @@ -1144,33 +1120,21 @@ subroutine int_specific_vol_dp(T, S, p_t, p_b, alpha_ref, HI, 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, & - bathyP, dP_tiny, useMassWghtInterp, US) + bathyP, dP_tiny, useMassWghtInterp) else ; select case (EOS%form_of_EOS) case (EOS_LINEAR) - if (present(US)) then - call int_spec_vol_dp_linear(T, S, p_t, p_b, alpha_ref, HI, EOS%kg_m3_to_R*EOS%Rho_T0_S0, & - EOS%kg_m3_to_R*EOS%dRho_dT, EOS%kg_m3_to_R*EOS%dRho_dS, dza, & - intp_dza, intx_dza, inty_dza, halo_size, & - bathyP, dP_tiny, useMassWghtInterp) - else - 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, & - bathyP, dP_tiny, useMassWghtInterp) - endif + call int_spec_vol_dp_linear(T, S, p_t, p_b, alpha_ref, HI, EOS%kg_m3_to_R*EOS%Rho_T0_S0, & + EOS%kg_m3_to_R*EOS%dRho_dT, EOS%kg_m3_to_R*EOS%dRho_dS, dza, & + intp_dza, intx_dza, inty_dza, halo_size, & + bathyP, dP_tiny, useMassWghtInterp) case (EOS_WRIGHT) - if (present(US)) then - call int_spec_vol_dp_wright(T, S, p_t, p_b, alpha_ref, HI, dza, intp_dza, intx_dza, & - inty_dza, halo_size, bathyP, dP_tiny, useMassWghtInterp, & - SV_scale=EOS%R_to_kg_m3, pres_scale=EOS%RL2_T2_to_Pa) - else - call int_spec_vol_dp_wright(T, S, p_t, p_b, alpha_ref, HI, dza, intp_dza, intx_dza, & - inty_dza, halo_size, bathyP, dP_tiny, useMassWghtInterp) - endif + call int_spec_vol_dp_wright(T, S, p_t, p_b, alpha_ref, HI, dza, intp_dza, intx_dza, & + inty_dza, halo_size, bathyP, dP_tiny, useMassWghtInterp, & + SV_scale=EOS%R_to_kg_m3, pres_scale=EOS%RL2_T2_to_Pa) 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, & - bathyP, dP_tiny, useMassWghtInterp, US) + bathyP, dP_tiny, useMassWghtInterp) end select ; endif end subroutine int_specific_vol_dp @@ -1179,7 +1143,7 @@ end subroutine int_specific_vol_dp !! pressure anomalies across layers, which are required for calculating the !! 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, bathyT, dz_neglect, useMassWghtInterp, US) + intz_dpa, intx_dpa, inty_dpa, bathyT, dz_neglect, useMassWghtInterp) type(hor_index_type), intent(in) :: HII !< Ocean horizontal index structures for the input arrays type(hor_index_type), intent(in) :: HIO !< Ocean horizontal index structures for the output arrays real, dimension(HII%isd:HII%ied,HII%jsd:HII%jed), & @@ -1219,8 +1183,6 @@ subroutine int_density_dz(T, S, z_t, z_b, rho_ref, rho_0, G_e, HII, HIO, EOS, dp real, optional, intent(in) :: dz_neglect !< A miniscule thickness change [Z ~> m] logical, optional, intent(in) :: useMassWghtInterp !< If true, uses mass weighting to !! interpolate T/S for top and bottom integrals. - type(unit_scale_type), optional, intent(in) :: US !< A dimensional unit scaling type - ! Local variables real :: rho_scale ! A multiplicative factor by which to scale density from kg m-3 to the ! desired units [R m3 kg-1 ~> 1] @@ -1231,10 +1193,10 @@ subroutine int_density_dz(T, S, z_t, z_b, rho_ref, rho_0, G_e, HII, HIO, EOS, dp 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, bathyT, dz_neglect, useMassWghtInterp, US) + intz_dpa, intx_dpa, inty_dpa, bathyT, dz_neglect, useMassWghtInterp) else ; select case (EOS%form_of_EOS) case (EOS_LINEAR) - rho_scale = 1.0 ; if (present(US)) rho_scale = EOS%kg_m3_to_R + rho_scale = EOS%kg_m3_to_R if (rho_scale /= 1.0) then call int_density_dz_linear(T, S, z_t, z_b, rho_ref, rho_0, G_e, HII, HIO, & rho_scale*EOS%Rho_T0_S0, rho_scale*EOS%dRho_dT, rho_scale*EOS%dRho_dS, & @@ -1245,8 +1207,8 @@ subroutine int_density_dz(T, S, z_t, z_b, rho_ref, rho_0, G_e, HII, HIO, EOS, dp dpa, intz_dpa, intx_dpa, inty_dpa, bathyT, dz_neglect, useMassWghtInterp) endif case (EOS_WRIGHT) - rho_scale = 1.0 ; if (present(US)) rho_scale = EOS%kg_m3_to_R - pres_scale = 1.0 ; if (present(US)) pres_scale = EOS%RL2_T2_to_Pa + rho_scale = EOS%kg_m3_to_R + pres_scale = EOS%RL2_T2_to_Pa if ((rho_scale /= 1.0) .or. (pres_scale /= 1.0)) then 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, bathyT, & @@ -1258,7 +1220,7 @@ subroutine int_density_dz(T, S, z_t, z_b, rho_ref, rho_0, G_e, HII, HIO, EOS, dp endif 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, bathyT, dz_neglect, useMassWghtInterp, US) + intz_dpa, intx_dpa, inty_dpa, bathyT, dz_neglect, useMassWghtInterp) end select ; endif end subroutine int_density_dz @@ -1377,6 +1339,7 @@ subroutine EOS_init(param_file, EOS, US) EOS%kg_m3_to_R = 1. ; if (present(US)) EOS%kg_m3_to_R = US%kg_m3_to_R EOS%R_to_kg_m3 = 1. ; if (present(US)) EOS%R_to_kg_m3 = US%R_to_kg_m3 EOS%RL2_T2_to_Pa = 1. ; if (present(US)) EOS%RL2_T2_to_Pa = US%RL2_T2_to_Pa + EOS%L_T_to_m_s = 1. ; if (present(US)) EOS%L_T_to_m_s = US%L_T_to_m_s end subroutine EOS_init @@ -1459,7 +1422,7 @@ end subroutine EOS_use_linear !! 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, & - bathyT, dz_neglect, useMassWghtInterp, US) + 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), & @@ -1499,8 +1462,6 @@ subroutine int_density_dz_generic(T, S, z_t, z_b, rho_ref, rho_0, G_e, HII, HIO, real, optional, intent(in) :: dz_neglect !< A miniscule thickness change [Z ~> m] logical, optional, intent(in) :: useMassWghtInterp !< If true, uses mass weighting to !! interpolate T/S for top and bottom integrals. - type(unit_scale_type), optional, intent(in) :: US !< A dimensional unit scaling type - ! Local variables real :: T5(5), S5(5) ! Temperatures and salinities at five quadrature points [degC] and [ppt] real :: p5(5) ! Pressures at five quadrature points, never rescaled from Pa [Pa] @@ -1535,9 +1496,9 @@ subroutine int_density_dz_generic(T, S, z_t, z_b, rho_ref, rho_0, G_e, HII, HIO, is = HIO%isc + ioff ; ie = HIO%iec + ioff js = HIO%jsc + joff ; je = HIO%jec + joff - rho_scale = 1.0 ; if (present(US)) rho_scale = EOS%kg_m3_to_R - GxRho = G_e * rho_0 ; if (present(US)) GxRho = EOS%RL2_T2_to_Pa * G_e * rho_0 - rho_ref_mks = rho_ref ; if (present(US)) rho_ref_mks = rho_ref * EOS%R_to_kg_m3 + rho_scale = EOS%kg_m3_to_R + GxRho = EOS%RL2_T2_to_Pa * G_e * rho_0 + rho_ref_mks = rho_ref * EOS%R_to_kg_m3 I_Rho = 1.0 / rho_0 do_massWeight = .false. @@ -1668,7 +1629,7 @@ end subroutine int_density_dz_generic !! T and S are linear profiles. subroutine int_density_dz_generic_plm (T_t, T_b, S_t, S_b, z_t, z_b, rho_ref, & rho_0, G_e, dz_subroundoff, bathyT, HII, HIO, EOS, dpa, & - intz_dpa, intx_dpa, inty_dpa, useMassWghtInterp, US) + intz_dpa, intx_dpa, inty_dpa, useMassWghtInterp) type(hor_index_type), intent(in) :: HII !< Ocean horizontal index structures for the input arrays type(hor_index_type), intent(in) :: HIO !< Ocean horizontal index structures for the output arrays real, dimension(HII%isd:HII%ied,HII%jsd:HII%jed), & @@ -1708,7 +1669,6 @@ subroutine int_density_dz_generic_plm (T_t, T_b, S_t, S_b, z_t, z_b, rho_ref, & !! divided by the y grid spacing [R L2 T-2 ~> Pa] logical, optional, intent(in) :: useMassWghtInterp !< If true, uses mass weighting to !! interpolate T/S for top and bottom integrals. - type(unit_scale_type), optional, intent(in) :: US !< A dimensional unit scaling type ! This subroutine calculates (by numerical quadrature) integrals of ! pressure anomalies across layers, which are required for calculating the @@ -1762,9 +1722,9 @@ subroutine int_density_dz_generic_plm (T_t, T_b, S_t, S_b, z_t, z_b, rho_ref, & Isq = HIO%IscB ; Ieq = HIO%IecB ; Jsq = HIO%JscB ; Jeq = HIO%JecB - rho_scale = 1.0 ; if (present(US)) rho_scale = EOS%kg_m3_to_R - GxRho = G_e * rho_0 ; if (present(US)) GxRho = EOS%RL2_T2_to_Pa * G_e * rho_0 - rho_ref_mks = rho_ref ; if (present(US)) rho_ref_mks = rho_ref * EOS%R_to_kg_m3 + rho_scale = EOS%kg_m3_to_R + GxRho = EOS%RL2_T2_to_Pa * G_e * rho_0 + rho_ref_mks = rho_ref * EOS%R_to_kg_m3 I_Rho = 1.0 / rho_0 massWeightToggle = 0. if (present(useMassWghtInterp)) then @@ -2102,7 +2062,7 @@ real function frac_dp_at_pos(T_t, T_b, S_t, S_b, z_t, z_b, rho_ref, G_e, pos, EO T5(n) = top_weight * T_t + bottom_weight * T_b p5(n) = ( top_weight * z_t + bottom_weight * z_b ) * ( G_e * rho_ref ) enddo - call calculate_density_array(T5, S5, p5, rho5, 1, 5, EOS, US=US) + call calculate_density_array(T5, S5, p5, rho5, 1, 5, EOS) rho5(:) = rho5(:) !- rho_ref ! Work with anomalies relative to rho_ref ! Use Bode's rule to estimate the average density diff --git a/src/framework/MOM_diag_remap.F90 b/src/framework/MOM_diag_remap.F90 index 83a7ce207c..cadd74950a 100644 --- a/src/framework/MOM_diag_remap.F90 +++ b/src/framework/MOM_diag_remap.F90 @@ -327,7 +327,7 @@ subroutine diag_remap_update(remap_cs, G, GV, US, h, T, S, eqn_of_state) GV%Z_to_H*G%bathyT(i,j), sum(h(i,j,:)), zInterfaces) elseif (remap_cs%vertical_coord == coordinateMode('RHO')) then !### I think that the conversion factor in the 2nd line should be GV%Z_to_H - call build_rho_column(get_rho_CS(remap_cs%regrid_cs), US, G%ke, & + call build_rho_column(get_rho_CS(remap_cs%regrid_cs), G%ke, & US%Z_to_m*G%bathyT(i,j), h(i,j,:), T(i,j,:), S(i,j,:), & eqn_of_state, zInterfaces, h_neglect, h_neglect_edge) elseif (remap_cs%vertical_coord == coordinateMode('SLIGHT')) then diff --git a/src/ice_shelf/MOM_ice_shelf.F90 b/src/ice_shelf/MOM_ice_shelf.F90 index 858af4e1ea..ad133cc4ab 100644 --- a/src/ice_shelf/MOM_ice_shelf.F90 +++ b/src/ice_shelf/MOM_ice_shelf.F90 @@ -376,9 +376,9 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) ! Calculate insitu densities and expansion coefficients call calculate_density(state%sst(:,j), state%sss(:,j), p_int, Rhoml(:), G%HI, & - CS%eqn_of_state, US) + CS%eqn_of_state) call calculate_density_derivs(state%sst(:,j), state%sss(:,j), p_int, dR0_dT, dR0_dS, G%HI, & - CS%eqn_of_state, US) + CS%eqn_of_state) do i=is,ie if ((state%ocean_mass(i,j) > US%RZ_to_kg_m2*CS%col_mass_melt_threshold) .and. & diff --git a/src/initialization/MOM_coord_initialization.F90 b/src/initialization/MOM_coord_initialization.F90 index b0155ae603..a70e761fa8 100644 --- a/src/initialization/MOM_coord_initialization.F90 +++ b/src/initialization/MOM_coord_initialization.F90 @@ -240,7 +240,7 @@ subroutine set_coord_from_TS_ref(Rlay, g_prime, GV, US, param_file, eqn_of_state ! The uppermost layer's density is set here. Subsequent layers' ! ! densities are determined from this value and the g values. ! ! T0 = 28.228 ; S0 = 34.5848 ; Pref = P_Ref - call calculate_density(T_ref, S_ref, P_ref, Rlay(1), eqn_of_state, US=US) + call calculate_density(T_ref, S_ref, P_ref, Rlay(1), eqn_of_state) ! These statements set the layer densities. ! do k=2,nz ; Rlay(k) = Rlay(k-1) + g_prime(k)*(GV%Rho0/GV%g_Earth) ; enddo @@ -291,7 +291,7 @@ subroutine set_coord_from_TS_profile(Rlay, g_prime, GV, US, param_file, eqn_of_s ! These statements set the interface reduced gravities. ! g_prime(1) = g_fs do k=1,nz ; Pref(k) = P_Ref ; enddo - call calculate_density(T0, S0, Pref, Rlay, 1, nz, eqn_of_state, US=US) + call calculate_density(T0, S0, Pref, Rlay, 1, nz, eqn_of_state) do k=2,nz; g_prime(k) = (GV%g_Earth/(GV%Rho0)) * (Rlay(k) - Rlay(k-1)) ; enddo call callTree_leave(trim(mdl)//'()') @@ -371,7 +371,7 @@ subroutine set_coord_from_TS_range(Rlay, g_prime, GV, US, param_file, eqn_of_sta g_prime(1) = g_fs do k=1,nz ; Pref(k) = P_Ref ; enddo - call calculate_density(T0, S0, Pref, Rlay, k_light, nz-k_light+1, eqn_of_state, US=US) + call calculate_density(T0, S0, Pref, Rlay, k_light, nz-k_light+1, eqn_of_state) ! Extrapolate target densities for the variable density mixed and buffer layers. do k=k_light-1,1,-1 Rlay(k) = 2.0*Rlay(k+1) - Rlay(k+2) diff --git a/src/initialization/MOM_state_initialization.F90 b/src/initialization/MOM_state_initialization.F90 index 2efceb5991..4ff22d202b 100644 --- a/src/initialization/MOM_state_initialization.F90 +++ b/src/initialization/MOM_state_initialization.F90 @@ -960,7 +960,7 @@ subroutine convert_thickness(h, G, GV, US, tv) do j=js,je do i=is,ie ; p_top(i,j) = p_bot(i,j) ; enddo call calculate_density(tv%T(:,j,k), tv%S(:,j,k), p_top(:,j), rho, G%HI, & - tv%eqn_of_state, US) + tv%eqn_of_state) do i=is,ie p_bot(i,j) = p_top(i,j) + HR_to_pres * (h(i,j,k) * rho(i)) enddo @@ -968,10 +968,10 @@ subroutine convert_thickness(h, G, GV, US, tv) do itt=1,max_itt call int_specific_vol_dp(tv%T(:,:,k), tv%S(:,:,k), p_top, p_bot, 0.0, G%HI, & - tv%eqn_of_state, dz_geo, US=US) + tv%eqn_of_state, dz_geo) if (itt < max_itt) then ; do j=js,je call calculate_density(tv%T(:,j,k), tv%S(:,j,k), p_bot(:,j), rho, G%HI, & - tv%eqn_of_state, US) + tv%eqn_of_state) ! Use Newton's method to correct the bottom value. ! The hydrostatic equation is sufficiently linear that no bounds-checking is needed. do i=is,ie @@ -1600,8 +1600,8 @@ subroutine initialize_temp_salt_fit(T, S, G, GV, US, param_file, eqn_of_state, P T0(k) = T_Ref enddo - call calculate_density(T0(1), S0(1), pres(1), rho_guess(1), eqn_of_state, US=US) - call calculate_density_derivs(T0, S0, pres, drho_dT, drho_dS, 1, 1, eqn_of_state, US=US) + call calculate_density(T0(1), S0(1), pres(1), rho_guess(1), eqn_of_state) + call calculate_density_derivs(T0, S0, pres, drho_dT, drho_dS, 1, 1, eqn_of_state) if (fit_salin) then ! A first guess of the layers' temperatures. @@ -1610,8 +1610,8 @@ subroutine initialize_temp_salt_fit(T, S, G, GV, US, param_file, eqn_of_state, P enddo ! Refine the guesses for each layer. do itt=1,6 - call calculate_density(T0, S0, pres, rho_guess, 1, nz, eqn_of_state, US=US) - call calculate_density_derivs(T0, S0, pres, drho_dT, drho_dS, 1, nz, eqn_of_state, US=US) + call calculate_density(T0, S0, pres, rho_guess, 1, nz, eqn_of_state) + call calculate_density_derivs(T0, S0, pres, drho_dT, drho_dS, 1, nz, eqn_of_state) do k=1,nz S0(k) = max(0.0, S0(k) + (GV%Rlay(k) - rho_guess(k)) / drho_dS(k)) enddo @@ -1622,8 +1622,8 @@ subroutine initialize_temp_salt_fit(T, S, G, GV, US, param_file, eqn_of_state, P T0(k) = T0(1) + (GV%Rlay(k) - rho_guess(1)) / drho_dT(1) enddo do itt=1,6 - call calculate_density(T0, S0, pres, rho_guess, 1, nz, eqn_of_state, US=US) - call calculate_density_derivs(T0, S0, pres, drho_dT, drho_dS, 1, nz, eqn_of_state, US=US) + call calculate_density(T0, S0, pres, rho_guess, 1, nz, eqn_of_state) + call calculate_density_derivs(T0, S0, pres, drho_dT, drho_dS, 1, nz, eqn_of_state) do k=1,nz T0(k) = T0(k) + (GV%Rlay(k) - rho_guess(k)) / drho_dT(k) enddo @@ -1869,7 +1869,7 @@ subroutine initialize_sponges_file(G, GV, US, use_temperature, tv, param_file, C call MOM_read_data(filename, salin_var, tmp2(:,:,:), G%Domain) do j=js,je - call calculate_density(tmp(:,j,1), tmp2(:,j,1), pres, tmp_2d(:,j), G%HI, tv%eqn_of_state, US) + call calculate_density(tmp(:,j,1), tmp2(:,j,1), pres, tmp_2d(:,j), G%HI, tv%eqn_of_state) enddo call set_up_sponge_ML_density(tmp_2d, G, CSp) @@ -2188,7 +2188,7 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, G, GV, US, PF, just_read_param press(:) = tv%P_Ref do k=1,kd ; do j=js,je - call calculate_density(temp_z(:,j,k), salt_z(:,j,k), press, rho_z(:,j,k), G%HI, eos, US) + call calculate_density(temp_z(:,j,k), salt_z(:,j,k), press, rho_z(:,j,k), G%HI, eos) enddo ; enddo call pass_var(temp_z,G%Domain) @@ -2449,7 +2449,7 @@ subroutine MOM_state_init_tests(G, GV, US, tv) S(k) = 35. + (0. * I_z_scale)*z(k) S_b(k) = 35. - (0. * I_z_scale)*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*US%m_to_Z*z(k), & - rho(k), tv%eqn_of_state, US=US) + rho(k), tv%eqn_of_state) P_tot = P_tot + GV%g_Earth * rho(k) * GV%H_to_Z*h(k) enddo diff --git a/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 b/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 index 744a801391..37f9cf2684 100644 --- a/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 +++ b/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 @@ -208,7 +208,7 @@ subroutine mixedlayer_restrat_general(h, uhtr, vhtr, tv, forces, dt, MLD_in, Var do j = js-1, je+1 dK(:) = 0.5 * h(:,j,1) ! Depth of center of surface layer call calculate_density(tv%T(:,j,1), tv%S(:,j,1), pRef_MLD, rhoSurf, G%HI, & - tv%eqn_of_state, US, halo=1) + tv%eqn_of_state, halo=1) deltaRhoAtK(:) = 0. MLD_fast(:,j) = 0. do k = 2, nz @@ -217,7 +217,7 @@ subroutine mixedlayer_restrat_general(h, uhtr, vhtr, tv, forces, dt, MLD_in, Var ! Mixed-layer depth, using sigma-0 (surface reference pressure) deltaRhoAtKm1(:) = deltaRhoAtK(:) ! Store value from previous iteration of K call calculate_density(tv%T(:,j,k), tv%S(:,j,k), pRef_MLD, deltaRhoAtK, G%HI, & - tv%eqn_of_state, US, halo=1) + tv%eqn_of_state, halo=1) do i = is-1,ie+1 deltaRhoAtK(i) = deltaRhoAtK(i) - rhoSurf(i) ! Density difference between layer K and surface enddo @@ -322,7 +322,7 @@ subroutine mixedlayer_restrat_general(h, uhtr, vhtr, tv, forces, dt, MLD_in, Var h_avail(i,j,k) = max(I4dt*G%areaT(i,j)*(h(i,j,k)-GV%Angstrom_H),0.0) enddo if (keep_going) then - call calculate_density(tv%T(:,j,k), tv%S(:,j,k), p0, rho_ml(:), G%HI, tv%eqn_of_state, US, halo=1) + call calculate_density(tv%T(:,j,k), tv%S(:,j,k), p0, rho_ml(:), G%HI, tv%eqn_of_state, halo=1) line_is_empty = .true. do i=is-1,ie+1 if (htot_fast(i,j) < MLD_fast(i,j)) then @@ -646,7 +646,7 @@ subroutine mixedlayer_restrat_BML(h, uhtr, vhtr, tv, forces, dt, G, GV, US, CS) htot(i,j) = 0.0 ; Rml_av(i,j) = 0.0 enddo do k=1,nkml - call calculate_density(tv%T(:,j,k), tv%S(:,j,k), p0, Rho0(:), G%HI, tv%eqn_of_state, US, halo=1) + call calculate_density(tv%T(:,j,k), tv%S(:,j,k), p0, Rho0(:), G%HI, tv%eqn_of_state, halo=1) do i=is-1,ie+1 Rml_av(i,j) = Rml_av(i,j) + h(i,j,k)*Rho0(i) htot(i,j) = htot(i,j) + h(i,j,k) diff --git a/src/parameterizations/lateral/MOM_thickness_diffuse.F90 b/src/parameterizations/lateral/MOM_thickness_diffuse.F90 index 4d42f05629..39884968f3 100644 --- a/src/parameterizations/lateral/MOM_thickness_diffuse.F90 +++ b/src/parameterizations/lateral/MOM_thickness_diffuse.F90 @@ -779,7 +779,7 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV S_u(I) = 0.25*((S(i,j,k) + S(i+1,j,k)) + (S(i,j,k-1) + S(i+1,j,k-1))) enddo call calculate_density_derivs(T_u, S_u, pres_u, drho_dT_u, & - drho_dS_u, (is-IsdB+1)-1, ie-is+2, tv%eqn_of_state, US=US) + drho_dS_u, (is-IsdB+1)-1, ie-is+2, tv%eqn_of_state) endif do I=is-1,ie @@ -1030,7 +1030,7 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV S_v(i) = 0.25*((S(i,j,k) + S(i,j+1,k)) + (S(i,j,k-1) + S(i,j+1,k-1))) enddo call calculate_density_derivs(T_v, S_v, pres_v, drho_dT_v, drho_dS_v, G%HI, & - tv%eqn_of_state, US) + tv%eqn_of_state) endif do i=is,ie if (calc_derivatives) then @@ -1262,7 +1262,7 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV S_u(I) = 0.5*(S(i,j,1) + S(i+1,j,1)) enddo call calculate_density_derivs(T_u, S_u, pres_u, drho_dT_u, drho_dS_u, & - (is-IsdB+1)-1, ie-is+2, tv%eqn_of_state, US=US) + (is-IsdB+1)-1, ie-is+2, tv%eqn_of_state) endif do I=is-1,ie uhD(I,j,1) = -uhtot(I,j) @@ -1292,7 +1292,7 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV S_v(i) = 0.5*(S(i,j,1) + S(i,j+1,1)) enddo call calculate_density_derivs(T_v, S_v, pres_v, drho_dT_v, drho_dS_v, G%HI, & - tv%eqn_of_state, US) + tv%eqn_of_state) endif do i=is,ie vhD(i,J,1) = -vhtot(i,J) diff --git a/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 b/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 index cc3a6e3f69..ff915222bf 100644 --- a/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 +++ b/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 @@ -466,12 +466,12 @@ subroutine bulkmixedlayer(h_3d, u_3d, v_3d, tv, fluxes, dt, ea, eb, G, GV, US, C do k=1,CS%nkml ; do i=is,ie p_ref(i) = p_ref(i) + 0.5*(GV%H_to_RZ*GV%g_Earth)*h(i,k) enddo ; enddo - call calculate_density_derivs(T(:,1), S(:,1), p_ref, dR0_dT, dR0_dS, G%HI, tv%eqn_of_state, US) + call calculate_density_derivs(T(:,1), S(:,1), p_ref, dR0_dT, dR0_dS, G%HI, tv%eqn_of_state) call calculate_density_derivs(T(:,1), S(:,1), p_ref_cv, dRcv_dT, dRcv_dS, G%HI, & - tv%eqn_of_state, US) + tv%eqn_of_state) do k=1,nz - call calculate_density(T(:,k), S(:,k), p_ref, R0(:,k), G%HI, tv%eqn_of_state, US) - call calculate_density(T(:,k), S(:,k), p_ref_cv, Rcv(:,k), G%HI, tv%eqn_of_state, US) + call calculate_density(T(:,k), S(:,k), p_ref, R0(:,k), G%HI, tv%eqn_of_state) + call calculate_density(T(:,k), S(:,k), p_ref_cv, Rcv(:,k), G%HI, tv%eqn_of_state) enddo if (id_clock_EOS>0) call cpu_clock_end(id_clock_EOS) diff --git a/src/parameterizations/vertical/MOM_diabatic_aux.F90 b/src/parameterizations/vertical/MOM_diabatic_aux.F90 index 3cde9ce91e..8eb702d45d 100644 --- a/src/parameterizations/vertical/MOM_diabatic_aux.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_aux.F90 @@ -446,7 +446,7 @@ subroutine insert_brine(h, tv, G, GV, US, fluxes, nkmb, CS, dt, id_brine_lay) h_2d(i,k) = MAX(h(i,j,k), GV%Angstrom_H) enddo - call calculate_density(T(:,k), S(:,k), p_ref_cv, Rcv(:,k), G%HI, tv%eqn_of_state, US) + call calculate_density(T(:,k), S(:,k), p_ref_cv, Rcv(:,k), G%HI, tv%eqn_of_state) enddo ! First, try to find an interior layer where inserting all the salt @@ -457,7 +457,7 @@ subroutine insert_brine(h, tv, G, GV, US, fluxes, nkmb, CS, dt, id_brine_lay) if ((G%mask2dT(i,j) > 0.0) .and. dzbr(i) < brine_dz .and. salt(i) > 0.) then s_new = S(i,k) + salt(i) / (GV%H_to_RZ * h_2d(i,k)) t0 = T(i,k) - call calculate_density(t0, s_new, tv%P_Ref, R_new, tv%eqn_of_state, US=US) + call calculate_density(t0, s_new, tv%P_Ref, R_new, tv%eqn_of_state) if (R_new < 0.5*(Rcv(i,k)+Rcv(i,k+1)) .and. s_new0.5) .and. N2_region_set(i)) then subMLN2(i,j) = gE_rho0 * (rho_deeper(i) - rho_subML(i)) / (GV%H_to_z * dH_N2(i)) endif ; enddo @@ -1006,7 +1006,7 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t pres(i) = pres(i) + d_pres(i) enddo call calculate_specific_vol_derivs(T2d(:,k), tv%S(:,j,k), p_lay(:), & - dSV_dT(:,j,k), dSV_dS(:,j,k), G%HI, tv%eqn_of_state, US=US) + dSV_dT(:,j,k), dSV_dS(:,j,k), G%HI, tv%eqn_of_state) do i=is,ie ; dSV_dT_2d(i,k) = dSV_dT(i,j,k) ; enddo enddo pen_TKE_2d(:,:) = 0.0 @@ -1348,7 +1348,7 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t ! Density derivatives call calculate_density_derivs(T2d(:,1), tv%S(:,j,1), SurfPressure, dRhodT, dRhodS, G%HI, & - tv%eqn_of_state, US) + tv%eqn_of_state) ! 1. Adjust netSalt to reflect dilution effect of FW flux ! 2. Add in the SW heating for purposes of calculating the net ! surface buoyancy flux affecting the top layer. diff --git a/src/parameterizations/vertical/MOM_diabatic_driver.F90 b/src/parameterizations/vertical/MOM_diabatic_driver.F90 index bdfb6b7a9e..5301fb5603 100644 --- a/src/parameterizations/vertical/MOM_diabatic_driver.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_driver.F90 @@ -2683,7 +2683,7 @@ subroutine layered_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_e !$OMP parallel do default(shared) do j=js,je call calculate_density(tv%T(:,j,1), tv%S(:,j,1), p_ref_cv, Rcv_ml(:,j), G%HI, & - tv%eqn_of_state, US) + tv%eqn_of_state) enddo call apply_sponge(h, dt, G, GV, US, ea, eb, CS%sponge_CSp, Rcv_ml) else diff --git a/src/parameterizations/vertical/MOM_diapyc_energy_req.F90 b/src/parameterizations/vertical/MOM_diapyc_energy_req.F90 index cde4b9e484..21eb272d70 100644 --- a/src/parameterizations/vertical/MOM_diapyc_energy_req.F90 +++ b/src/parameterizations/vertical/MOM_diapyc_energy_req.F90 @@ -298,7 +298,7 @@ subroutine diapyc_energy_req_calc(h_in, T_in, S_in, Kd, energy_Kd, dt, tv, & ! Solve the tridiagonal equations for new temperatures. - call calculate_specific_vol_derivs(T0, S0, p_lay, dSV_dT, dSV_dS, 1, nz, tv%eqn_of_state, US=US) + call calculate_specific_vol_derivs(T0, S0, p_lay, dSV_dT, dSV_dS, 1, nz, tv%eqn_of_state) do k=1,nz dMass = GV%H_to_RZ * h_tr(k) @@ -939,7 +939,7 @@ subroutine diapyc_energy_req_calc(h_in, T_in, S_in, Kd, energy_Kd, dt, tv, & N2(1) = 0.0 ; N2(nz+1) = 0.0 do K=2,nz call calculate_density(0.5*(T0(k-1) + T0(k)), 0.5*(S0(k-1) + S0(k)), & - pres(K), rho_here, tv%eqn_of_state, US=US) + pres(K), rho_here, tv%eqn_of_state) N2(K) = ((US%L_to_Z**2*GV%g_Earth) * rho_here / (0.5*GV%H_to_Z*(h_tr(k-1) + h_tr(k)))) * & ( 0.5*(dSV_dT(k-1) + dSV_dT(k)) * (T0(k-1) - T0(k)) + & 0.5*(dSV_dS(k-1) + dSV_dS(k)) * (S0(k-1) - S0(k)) ) @@ -950,7 +950,7 @@ subroutine diapyc_energy_req_calc(h_in, T_in, S_in, Kd, energy_Kd, dt, tv, & N2(1) = 0.0 ; N2(nz+1) = 0.0 do K=2,nz call calculate_density(0.5*(Tf(k-1) + Tf(k)), 0.5*(Sf(k-1) + Sf(k)), & - pres(K), rho_here, tv%eqn_of_state, US=US) + pres(K), rho_here, tv%eqn_of_state) N2(K) = ((US%L_to_Z**2*GV%g_Earth) * rho_here / (0.5*GV%H_to_Z*(h_tr(k-1) + h_tr(k)))) * & ( 0.5*(dSV_dT(k-1) + dSV_dT(k)) * (Tf(k-1) - Tf(k)) + & 0.5*(dSV_dS(k-1) + dSV_dS(k)) * (Sf(k-1) - Sf(k)) ) diff --git a/src/parameterizations/vertical/MOM_entrain_diffusive.F90 b/src/parameterizations/vertical/MOM_entrain_diffusive.F90 index 100e79aba2..a44dc5c744 100644 --- a/src/parameterizations/vertical/MOM_entrain_diffusive.F90 +++ b/src/parameterizations/vertical/MOM_entrain_diffusive.F90 @@ -700,7 +700,7 @@ subroutine entrainment_diffusive(h, tv, fluxes, dt, G, GV, US, CS, ea, eb, & call determine_dSkb(h_bl, Sref, Ent_bl, eakb, is, ie, kmb, G, GV, & .true., dS_kb, dS_anom_lim=dS_anom_lim) do k=nz-1,kb_min,-1 - call calculate_density(tv%T(:,j,k), tv%S(:,j,k), pres, Rcv, G%HI, tv%eqn_of_state, US) + call calculate_density(tv%T(:,j,k), tv%S(:,j,k), pres, Rcv, G%HI, tv%eqn_of_state) do i=is,ie if ((k>kb(i)) .and. (F(i,k) > 0.0)) then ! Within a time step, a layer may entrain no more than its @@ -784,7 +784,7 @@ subroutine entrainment_diffusive(h, tv, fluxes, dt, G, GV, US, CS, ea, eb, & else ! not bulkmixedlayer do k=K2,nz-1; - call calculate_density(tv%T(:,j,k), tv%S(:,j,k), pres, Rcv, G%HI, tv%eqn_of_state, US) + call calculate_density(tv%T(:,j,k), tv%S(:,j,k), pres, Rcv, G%HI, tv%eqn_of_state) do i=is,ie ; if (F(i,k) > 0.0) then ! Within a time step, a layer may entrain no more than ! its thickness for correction. This limitation should @@ -850,7 +850,7 @@ subroutine entrainment_diffusive(h, tv, fluxes, dt, G, GV, US, CS, ea, eb, & endif enddo call calculate_density_derivs(T_eos, S_eos, pressure, dRho_dT, dRho_dS, G%HI, & - tv%eqn_of_state, US) + tv%eqn_of_state) do i=is,ie if ((k>kmb) .and. (k 0) then call calculate_density(tv%T(:,j,nkmb), tv%S(:,j,nkmb), p_Ref(:), Rcv_BL(:), isj, iej-isj+1, & - tv%eqn_of_state, US=US) + tv%eqn_of_state) else Rcv_BL(:) = -1.0 endif @@ -245,11 +245,11 @@ subroutine geothermal(h, tv, dt, ea, eb, G, GV, US, CS, halo) Rcv = 0.0 ; dRcv_dT = 0.0 ! Is this OK? else call calculate_density(tv%T(i,j,k), tv%S(i,j,k), tv%P_Ref, & - Rcv, tv%eqn_of_state, US=US) + Rcv, tv%eqn_of_state) T2(1) = tv%T(i,j,k) ; S2(1) = tv%S(i,j,k) T2(2) = tv%T(i,j,k_tgt) ; S2(2) = tv%S(i,j,k_tgt) call calculate_density_derivs(T2(:), S2(:), p_Ref(:), dRcv_dT_, dRcv_dS_, 1, 2, & - tv%eqn_of_state, US=US) + tv%eqn_of_state) dRcv_dT = 0.5*(dRcv_dT_(1) + dRcv_dT_(2)) endif diff --git a/src/parameterizations/vertical/MOM_internal_tide_input.F90 b/src/parameterizations/vertical/MOM_internal_tide_input.F90 index 3ba5520117..d366cb93d8 100644 --- a/src/parameterizations/vertical/MOM_internal_tide_input.F90 +++ b/src/parameterizations/vertical/MOM_internal_tide_input.F90 @@ -210,7 +210,7 @@ subroutine find_N2_bottom(h, tv, T_f, S_f, h2, fluxes, G, GV, US, N2_bot) Salin_Int(i) = 0.5 * (S_f(i,j,k) + S_f(i,j,k-1)) enddo call calculate_density_derivs(Temp_int, Salin_int, pres, dRho_dT(:), dRho_dS(:), G%HI, & - tv%eqn_of_state, US) + tv%eqn_of_state) do i=is,ie dRho_int(i,K) = max(dRho_dT(i)*(T_f(i,j,k) - T_f(i,j,k-1)) + & dRho_dS(i)*(S_f(i,j,k) - S_f(i,j,k-1)), 0.0) diff --git a/src/parameterizations/vertical/MOM_kappa_shear.F90 b/src/parameterizations/vertical/MOM_kappa_shear.F90 index 5e11ecee60..73a170eae2 100644 --- a/src/parameterizations/vertical/MOM_kappa_shear.F90 +++ b/src/parameterizations/vertical/MOM_kappa_shear.F90 @@ -911,7 +911,7 @@ subroutine kappa_shear_column(kappa, tke, dt, nzc, f2, surface_pres, & Sal_int(K) = 0.5*(Sal(k-1) + Sal(k)) enddo call calculate_density_derivs(T_int, Sal_int, pressure, dbuoy_dT, dbuoy_dS, 2, nzc-1, & - tv%eqn_of_state, US=US, scale=-g_R0) + tv%eqn_of_state, scale=-g_R0) else do K=1,nzc+1 ; dbuoy_dT(K) = -g_R0 ; dbuoy_dS(K) = 0.0 ; enddo endif diff --git a/src/parameterizations/vertical/MOM_regularize_layers.F90 b/src/parameterizations/vertical/MOM_regularize_layers.F90 index 43ba5211f7..e037697353 100644 --- a/src/parameterizations/vertical/MOM_regularize_layers.F90 +++ b/src/parameterizations/vertical/MOM_regularize_layers.F90 @@ -312,7 +312,7 @@ subroutine regularize_surface(h, tv, dt, ea, eb, G, GV, US, CS) do j=js,je ; if (do_j(j)) then ! call cpu_clock_begin(id_clock_EOS) -! call calculate_density_derivs(T(:,1), S(:,1), p_ref_cv, dRcv_dT, dRcv_dS, G%HI, tv%eqn_of_state, US) +! call calculate_density_derivs(T(:,1), S(:,1), p_ref_cv, dRcv_dT, dRcv_dS, G%HI, tv%eqn_of_state) ! call cpu_clock_end(id_clock_EOS) do k=1,nz ; do i=is,ie ; d_ea(i,k) = 0.0 ; d_eb(i,k) = 0.0 ; enddo ; enddo @@ -444,7 +444,7 @@ subroutine regularize_surface(h, tv, dt, ea, eb, G, GV, US, CS) if (det_any) then call cpu_clock_begin(id_clock_EOS) do k=1,nkmb - call calculate_density(T_2d(:,k), S_2d(:,k), p_ref_cv, Rcv(:,k), G%HI, tv%eqn_of_state, US) + call calculate_density(T_2d(:,k), S_2d(:,k), p_ref_cv, Rcv(:,k), G%HI, tv%eqn_of_state) enddo call cpu_clock_end(id_clock_EOS) diff --git a/src/parameterizations/vertical/MOM_set_diffusivity.F90 b/src/parameterizations/vertical/MOM_set_diffusivity.F90 index a65be62b3a..b333f04a62 100644 --- a/src/parameterizations/vertical/MOM_set_diffusivity.F90 +++ b/src/parameterizations/vertical/MOM_set_diffusivity.F90 @@ -715,10 +715,10 @@ subroutine find_TKE_to_Kd(h, tv, dRho_int, N2_lay, j, dt, G, GV, US, CS, & do i=is,ie ; p_0(i) = 0.0 ; p_ref(i) = tv%P_Ref ; enddo do k=1,nz call calculate_density(tv%T(:,j,k), tv%S(:,j,k), p_0, rho_0(:,k), G%HI, & - tv%eqn_of_state, US) + tv%eqn_of_state) enddo call calculate_density(tv%T(:,j,kmb), tv%S(:,j,kmb), p_ref, Rcv_kmb, G%HI, & - tv%eqn_of_state, US) + tv%eqn_of_state) kb_min = kmb+1 do i=is,ie @@ -907,7 +907,7 @@ subroutine find_N2(h, tv, T_f, S_f, fluxes, j, G, GV, US, CS, dRho_int, & Salin_Int(i) = 0.5 * (S_f(i,j,k) + S_f(i,j,k-1)) enddo call calculate_density_derivs(Temp_int, Salin_int, pres, dRho_dT(:,K), dRho_dS(:,K), G%HI, & - tv%eqn_of_state, US) + tv%eqn_of_state) do i=is,ie dRho_int(i,K) = max(dRho_dT(i,K)*(T_f(i,j,k) - T_f(i,j,k-1)) + & dRho_dS(i,K)*(S_f(i,j,k) - S_f(i,j,k-1)), 0.0) @@ -1066,7 +1066,7 @@ subroutine double_diffusion(tv, h, T_f, S_f, j, G, GV, US, CS, Kd_T_dd, Kd_S_dd) Salin_Int(i) = 0.5 * (S_f(i,j,k-1) + S_f(i,j,k)) enddo call calculate_density_derivs(Temp_int, Salin_int, pres, dRho_dT, dRho_dS, G%HI, & - tv%eqn_of_state, US) + tv%eqn_of_state) do i=is,ie alpha_dT = -1.0*dRho_dT(i) * (T_f(i,j,k-1) - T_f(i,j,k)) @@ -1819,7 +1819,7 @@ subroutine set_density_ratios(h, tv, kb, G, GV, US, CS, j, ds_dsp1, rho_0) eps = 0.1 do i=is,ie ; p_ref(i) = tv%P_Ref ; enddo do k=1,kmb - call calculate_density(tv%T(:,j,k), tv%S(:,j,k), p_ref, Rcv(:,k), G%HI, tv%eqn_of_state, US) + call calculate_density(tv%T(:,j,k), tv%S(:,j,k), p_ref, Rcv(:,k), G%HI, tv%eqn_of_state) enddo do i=is,ie if (kb(i) <= nz-1) then diff --git a/src/parameterizations/vertical/MOM_set_viscosity.F90 b/src/parameterizations/vertical/MOM_set_viscosity.F90 index 4cd6a64684..6a2ce60f96 100644 --- a/src/parameterizations/vertical/MOM_set_viscosity.F90 +++ b/src/parameterizations/vertical/MOM_set_viscosity.F90 @@ -317,7 +317,7 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, symmetrize) !$OMP parallel do default(shared) do k=1,nkmb ; do j=Jsq,Jeq+1 call calculate_density(tv%T(:,j,k), tv%S(:,j,k), p_ref, Rml(:,j,k), start, npts, & - tv%eqn_of_state, US=US) + tv%eqn_of_state) enddo ; enddo endif @@ -574,7 +574,7 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, symmetrize) press(i) = press(i) + (GV%H_to_RZ*GV%g_Earth) * h_vel(i,k) enddo ; enddo call calculate_density_derivs(T_EOS, S_EOS, press, dR_dT, dR_dS, & - is-G%IsdB+1, ie-is+1, tv%eqn_of_state, US=US) + is-G%IsdB+1, ie-is+1, tv%eqn_of_state) endif do i=is,ie ; if (do_i(i)) then @@ -1278,7 +1278,7 @@ subroutine set_viscous_ML(u, v, h, tv, forces, visc, dt, G, GV, US, CS, symmetri S_EOS(I) = (h(i,j,k2)*tv%S(i,j,k2) + h(i+1,j,k2)*tv%S(i+1,j,k2)) * I_2hlay enddo call calculate_density_derivs(T_EOS, S_EOS, press, dR_dT, dR_dS, & - Isq-G%IsdB+1, Ieq-Isq+1, tv%eqn_of_state, US=US) + Isq-G%IsdB+1, Ieq-Isq+1, tv%eqn_of_state) endif do I=Isq,Ieq ; if (do_i(I)) then @@ -1399,7 +1399,7 @@ subroutine set_viscous_ML(u, v, h, tv, forces, visc, dt, G, GV, US, CS, symmetri if (use_EOS) then call calculate_density_derivs(T_EOS, S_EOS, forces%p_surf(:,j), dR_dT, dR_dS, & - Isq-G%IsdB+1, Ieq-Isq+1, tv%eqn_of_state, US=US) + Isq-G%IsdB+1, Ieq-Isq+1, tv%eqn_of_state) endif do I=Isq,Ieq ; if (do_i(I)) then @@ -1515,7 +1515,7 @@ subroutine set_viscous_ML(u, v, h, tv, forces, visc, dt, G, GV, US, CS, symmetri S_EOS(i) = (h(i,j,k2)*tv%S(i,j,k2) + h(i,j+1,k2)*tv%S(i,j+1,k2)) * I_2hlay enddo call calculate_density_derivs(T_EOS, S_EOS, press, dR_dT, dR_dS, & - is-G%IsdB+1, ie-is+1, tv%eqn_of_state, US=US) + is-G%IsdB+1, ie-is+1, tv%eqn_of_state) endif do i=is,ie ; if (do_i(i)) then @@ -1636,7 +1636,7 @@ subroutine set_viscous_ML(u, v, h, tv, forces, visc, dt, G, GV, US, CS, symmetri if (use_EOS) then call calculate_density_derivs(T_EOS, S_EOS, forces%p_surf(:,j), dR_dT, dR_dS, & - is-G%IsdB+1, ie-is+1, tv%eqn_of_state, US=US) + is-G%IsdB+1, ie-is+1, tv%eqn_of_state) endif do i=is,ie ; if (do_i(i)) then diff --git a/src/tracer/MOM_neutral_diffusion.F90 b/src/tracer/MOM_neutral_diffusion.F90 index 6a109b7cba..e193ac9023 100644 --- a/src/tracer/MOM_neutral_diffusion.F90 +++ b/src/tracer/MOM_neutral_diffusion.F90 @@ -8,7 +8,7 @@ module MOM_neutral_diffusion use MOM_domains, only : pass_var use MOM_diag_mediator, only : diag_ctrl, time_type use MOM_diag_mediator, only : post_data, register_diag_field -use MOM_EOS, only : EOS_type, EOS_manual_init, calculate_compress, calculate_density_derivs +use MOM_EOS, only : EOS_type, EOS_manual_init, calculate_density_derivs use MOM_EOS, only : calculate_density, calculate_density_second_derivs use MOM_EOS, only : extract_member_EOS, EOS_LINEAR, EOS_TEOS10, EOS_WRIGHT use MOM_error_handler, only : MOM_error, FATAL, WARNING, MOM_mesg, is_root_pe @@ -391,18 +391,18 @@ subroutine neutral_diffusion_calc_coeffs(G, GV, US, h, T, S, CS) do k = 1, G%ke+1 if (CS%ref_pres<0) ref_pres(:) = CS%Pint(:,j,k) call calculate_density_derivs(CS%Tint(:,j,k), CS%Sint(:,j,k), ref_pres, & - CS%dRdT(:,j,k), CS%dRdS(:,j,k), G%isc-1, G%iec-G%isc+3, CS%EOS, US) + CS%dRdT(:,j,k), CS%dRdS(:,j,k), G%isc-1, G%iec-G%isc+3, CS%EOS) enddo else ! Discontinuous reconstruction do k = 1, G%ke if (CS%ref_pres<0) ref_pres(:) = CS%Pint(:,j,k) ! Calculate derivatives for the top interface call calculate_density_derivs(CS%T_i(:,j,k,1), CS%S_i(:,j,k,1), ref_pres, & - CS%dRdT_i(:,j,k,1), CS%dRdS_i(:,j,k,1), G%isc-1, G%iec-G%isc+3, CS%EOS, US) + CS%dRdT_i(:,j,k,1), CS%dRdS_i(:,j,k,1), G%isc-1, G%iec-G%isc+3, CS%EOS) if (CS%ref_pres<0) ref_pres(:) = CS%Pint(:,j,k+1) ! Calcualte derivatives at the bottom interface call calculate_density_derivs(CS%T_i(:,j,k,2), CS%S_i(:,j,k,2), ref_pres, & - CS%dRdT_i(:,j,k,2), CS%dRdS_i(:,j,k,2), G%isc-1, G%iec-G%isc+3, CS%EOS, US) + CS%dRdT_i(:,j,k,2), CS%dRdS_i(:,j,k,2), G%isc-1, G%iec-G%isc+3, CS%EOS) enddo endif enddo @@ -1767,19 +1767,19 @@ subroutine calc_delta_rho_and_derivs(CS, US, T1, S1, p1_in, T2, S2, p2_in, drho, ! Use the full linear equation of state to calculate the difference in density (expensive!) if (TRIM(CS%delta_rho_form) == 'full') then pmid = 0.5 * (p1 + p2) - call calculate_density( T1, S1, pmid, rho1, CS%EOS, US=US ) - call calculate_density( T2, S2, pmid, rho2, CS%EOS, US=US ) + call calculate_density( T1, S1, pmid, rho1, CS%EOS) + call calculate_density( T2, S2, pmid, rho2, CS%EOS) drho = rho1 - rho2 ! Use the density derivatives at the average of pressures and the differentces int temperature elseif (TRIM(CS%delta_rho_form) == 'mid_pressure') then pmid = 0.5 * (p1 + p2) if (CS%ref_pres>=0) pmid = CS%ref_pres - call calculate_density_derivs(T1, S1, pmid, drdt1, drds1, CS%EOS, US) - call calculate_density_derivs(T2, S2, pmid, drdt2, drds2, CS%EOS, US) + call calculate_density_derivs(T1, S1, pmid, drdt1, drds1, CS%EOS) + call calculate_density_derivs(T2, S2, pmid, drdt2, drds2, CS%EOS) drho = delta_rho_from_derivs( T1, S1, p1, drdt1, drds1, T2, S2, p2, drdt2, drds2) elseif (TRIM(CS%delta_rho_form) == 'local_pressure') then - call calculate_density_derivs(T1, S1, p1, drdt1, drds1, CS%EOS, US) - call calculate_density_derivs(T2, S2, p2, drdt2, drds2, CS%EOS, US) + call calculate_density_derivs(T1, S1, p1, drdt1, drds1, CS%EOS) + call calculate_density_derivs(T2, S2, p2, drdt2, drds2, CS%EOS) drho = delta_rho_from_derivs( T1, S1, p1, drdt1, drds1, T2, S2, p2, drdt2, drds2) else call MOM_error(FATAL, "delta_rho_form is not recognized") diff --git a/src/tracer/MOM_tracer_Z_init.F90 b/src/tracer/MOM_tracer_Z_init.F90 index 76ca2dac4a..c2748544c8 100644 --- a/src/tracer/MOM_tracer_Z_init.F90 +++ b/src/tracer/MOM_tracer_Z_init.F90 @@ -801,9 +801,9 @@ subroutine determine_temperature(temp, salt, R_tgt, p_ref, niter, land_fill, h, adjust_salt = .true. iter_loop: do itt = 1,niter do k=1, nz - call calculate_density(T(:,k), S(:,k), press, rho(:,k), 1, nx, eos, US=US) + call calculate_density(T(:,k), S(:,k), press, rho(:,k), 1, nx, eos) call calculate_density_derivs(T(:,k), S(:,k), press, drho_dT(:,k), drho_dS(:,k), 1, nx, & - eos, US=US) + eos) enddo do k=k_start,nz ; do i=1,nx @@ -831,9 +831,9 @@ subroutine determine_temperature(temp, salt, R_tgt, p_ref, niter, land_fill, h, if (adjust_salt .and. old_fit) then ; do itt = 1,niter do k=1, nz - call calculate_density(T(:,k), S(:,k), press, rho(:,k), 1, nx, eos, US=US) + call calculate_density(T(:,k), S(:,k), press, rho(:,k), 1, nx, eos) call calculate_density_derivs(T(:,k), S(:,k), press, drho_dT(:,k), drho_dS(:,k), 1, nx, & - eos, US=US) + eos) enddo do k=k_start,nz ; do i=1,nx ! if (abs(rho(i,k)-R_tgt(k))>tol_rho .and. hin(i,k)>h_massless .and. abs(T(i,k)-land_fill) < epsln ) then diff --git a/src/tracer/MOM_tracer_hor_diff.F90 b/src/tracer/MOM_tracer_hor_diff.F90 index 6064589019..30a71951ba 100644 --- a/src/tracer/MOM_tracer_hor_diff.F90 +++ b/src/tracer/MOM_tracer_hor_diff.F90 @@ -701,7 +701,7 @@ subroutine tracer_epipycnal_ML_diff(h, dt, Tr, ntr, khdt_epi_x, khdt_epi_y, G, & !$OMP parallel do default(shared) do k=1,nkmb ; do j=js-2,je+2 call calculate_density(tv%T(:,j,k),tv%S(:,j,k), p_ref_cv, rho_coord(:,j,k), G%HI, & - tv%eqn_of_state, US, halo=2) + tv%eqn_of_state, halo=2) enddo ; enddo do j=js-2,je+2 ; do i=is-2,ie+2 diff --git a/src/user/DOME_initialization.F90 b/src/user/DOME_initialization.F90 index 315e56051c..8330078555 100644 --- a/src/user/DOME_initialization.F90 +++ b/src/user/DOME_initialization.F90 @@ -359,13 +359,13 @@ subroutine DOME_set_OBC_data(OBC, tv, G, GV, US, param_file, tr_Reg) ! target density and a salinity of 35 psu. This code is taken from ! USER_initialize_temp_sal. pres(:) = tv%P_Ref ; S0(:) = 35.0 ; T0(1) = 25.0 - call calculate_density(T0(1), S0(1), pres(1), rho_guess(1), tv%eqn_of_state, US=US) - call calculate_density_derivs(T0, S0, pres, drho_dT, drho_dS, 1, 1, tv%eqn_of_state, US=US) + call calculate_density(T0(1), S0(1), pres(1), rho_guess(1), tv%eqn_of_state) + call calculate_density_derivs(T0, S0, pres, drho_dT, drho_dS, 1, 1, tv%eqn_of_state) do k=1,nz ; T0(k) = T0(1) + (GV%Rlay(k)-rho_guess(1)) / drho_dT(1) ; enddo do itt=1,6 - call calculate_density(T0, S0, pres, rho_guess, 1, nz, tv%eqn_of_state, US=US) - call calculate_density_derivs(T0, S0, pres, drho_dT, drho_dS, 1, nz, tv%eqn_of_state, US=US) + call calculate_density(T0, S0, pres, rho_guess, 1, nz, tv%eqn_of_state) + call calculate_density_derivs(T0, S0, pres, drho_dT, drho_dS, 1, nz, tv%eqn_of_state) do k=1,nz ; T0(k) = T0(k) + (GV%Rlay(k)-rho_guess(k)) / drho_dT(k) ; enddo enddo diff --git a/src/user/ISOMIP_initialization.F90 b/src/user/ISOMIP_initialization.F90 index c189cf0490..9f677f4e98 100644 --- a/src/user/ISOMIP_initialization.F90 +++ b/src/user/ISOMIP_initialization.F90 @@ -362,10 +362,10 @@ subroutine ISOMIP_initialize_temperature_salinity ( T, S, h, G, GV, US, param_fi ! call MOM_mesg(mesg,5) enddo - call calculate_density_derivs(T0, S0, pres, drho_dT, drho_dS, 1, 1, eqn_of_state, US) + call calculate_density_derivs(T0, S0, pres, drho_dT, drho_dS, 1, 1, eqn_of_state) ! write(mesg,*) 'computed drho_dS, drho_dT', drho_dS(1), drho_dT(1) ! call MOM_mesg(mesg,5) - call calculate_density(T0(1), S0(1), pres(1), rho_guess(1), eqn_of_state, US=US) + call calculate_density(T0(1), S0(1), pres(1), rho_guess(1), eqn_of_state) if (fit_salin) then ! A first guess of the layers' salinity. @@ -374,8 +374,8 @@ subroutine ISOMIP_initialize_temperature_salinity ( T, S, h, G, GV, US, param_fi enddo ! Refine the guesses for each layer. do itt=1,6 - call calculate_density(T0, S0, pres, rho_guess, 1, nz, eqn_of_state, US=US) - call calculate_density_derivs(T0, S0, pres, drho_dT, drho_dS, 1, nz, eqn_of_state, US) + call calculate_density(T0, S0, pres, rho_guess, 1, nz, eqn_of_state) + call calculate_density_derivs(T0, S0, pres, drho_dT, drho_dS, 1, nz, eqn_of_state) do k=1,nz S0(k) = max(0.0, S0(k) + (GV%Rlay(k) - rho_guess(k)) / drho_dS1) enddo @@ -388,8 +388,8 @@ subroutine ISOMIP_initialize_temperature_salinity ( T, S, h, G, GV, US, param_fi enddo do itt=1,6 - call calculate_density(T0, S0, pres, rho_guess, 1, nz, eqn_of_state, US=US) - call calculate_density_derivs(T0, S0, pres, drho_dT, drho_dS, 1, nz, eqn_of_state, US) + call calculate_density(T0, S0, pres, rho_guess, 1, nz, eqn_of_state) + call calculate_density_derivs(T0, S0, pres, drho_dT, drho_dS, 1, nz, eqn_of_state) do k=1,nz T0(k) = T0(k) + (GV%Rlay(k) - rho_guess(k)) / drho_dT(k) enddo diff --git a/src/user/RGC_initialization.F90 b/src/user/RGC_initialization.F90 index 6dbee6cea7..61ccbf51ff 100644 --- a/src/user/RGC_initialization.F90 +++ b/src/user/RGC_initialization.F90 @@ -213,7 +213,7 @@ subroutine RGC_initialize_sponges(G, GV, US, tv, u, v, PF, use_ALE, CSp, ACSp) do i=is-1,ie ; pres(i) = tv%P_Ref ; enddo do j=js,je - call calculate_density(T(:,j,1), S(:,j,1), pres, tmp(:,j), G%HI, tv%eqn_of_state, US) + call calculate_density(T(:,j,1), S(:,j,1), pres, tmp(:,j), G%HI, tv%eqn_of_state) enddo call set_up_sponge_ML_density(tmp, G, CSp) diff --git a/src/user/benchmark_initialization.F90 b/src/user/benchmark_initialization.F90 index 766474b364..492e51374c 100644 --- a/src/user/benchmark_initialization.F90 +++ b/src/user/benchmark_initialization.F90 @@ -152,8 +152,8 @@ subroutine benchmark_initialize_thickness(h, G, GV, US, param_file, eqn_of_state pres(k) = P_Ref ; S0(k) = 35.0 enddo T0(k1) = 29.0 - call calculate_density(T0(k1), S0(k1), pres(k1), rho_guess(k1), eqn_of_state, US=US) - call calculate_density_derivs(T0, S0, pres, drho_dT, drho_dS, k1, 1, eqn_of_state, US=US) + call calculate_density(T0(k1), S0(k1), pres(k1), rho_guess(k1), eqn_of_state) + call calculate_density_derivs(T0, S0, pres, drho_dT, drho_dS, k1, 1, eqn_of_state) ! A first guess of the layers' temperatures. do k=1,nz @@ -162,8 +162,8 @@ subroutine benchmark_initialize_thickness(h, G, GV, US, param_file, eqn_of_state ! Refine the guesses for each layer. do itt=1,6 - call calculate_density(T0, S0, pres, rho_guess, 1, nz, eqn_of_state, US=US) - call calculate_density_derivs(T0, S0, pres, drho_dT, drho_dS, 1, nz, eqn_of_state, US=US) + call calculate_density(T0, S0, pres, rho_guess, 1, nz, eqn_of_state) + call calculate_density_derivs(T0, S0, pres, drho_dT, drho_dS, 1, nz, eqn_of_state) do k=1,nz T0(k) = T0(k) + (GV%Rlay(k) - rho_guess(k)) / drho_dT(k) enddo @@ -257,8 +257,8 @@ subroutine benchmark_init_temperature_salinity(T, S, G, GV, US, param_file, & enddo T0(k1) = 29.0 - call calculate_density(T0(k1), S0(k1), pres(k1), rho_guess(k1), eqn_of_state, US=US) - call calculate_density_derivs(T0, S0, pres, drho_dT, drho_dS, k1, 1, eqn_of_state, US=US) + call calculate_density(T0(k1), S0(k1), pres(k1), rho_guess(k1), eqn_of_state) + call calculate_density_derivs(T0, S0, pres, drho_dT, drho_dS, k1, 1, eqn_of_state) ! A first guess of the layers' temperatures. ! do k=1,nz @@ -267,8 +267,8 @@ subroutine benchmark_init_temperature_salinity(T, S, G, GV, US, param_file, & ! Refine the guesses for each layer. ! do itt = 1,6 - call calculate_density(T0, S0, pres, rho_guess, 1, nz, eqn_of_state, US=US) - call calculate_density_derivs(T0, S0, pres, drho_dT, drho_dS, 1, nz, eqn_of_state, US=US) + call calculate_density(T0, S0, pres, rho_guess, 1, nz, eqn_of_state) + call calculate_density_derivs(T0, S0, pres, drho_dT, drho_dS, 1, nz, eqn_of_state) do k=1,nz T0(k) = T0(k) + (GV%Rlay(k) - rho_guess(k)) / drho_dT(k) enddo diff --git a/src/user/user_change_diffusivity.F90 b/src/user/user_change_diffusivity.F90 index f33d772352..834a624b7e 100644 --- a/src/user/user_change_diffusivity.F90 +++ b/src/user/user_change_diffusivity.F90 @@ -107,11 +107,11 @@ subroutine user_change_diff(h, tv, G, GV, US, CS, Kd_lay, Kd_int, T_f, S_f, Kd_i do j=js,je if (present(T_f) .and. present(S_f)) then do k=1,nz - call calculate_density(T_f(:,j,k), S_f(:,j,k), p_ref, Rcv(:,k), G%HI, tv%eqn_of_state, US) + call calculate_density(T_f(:,j,k), S_f(:,j,k), p_ref, Rcv(:,k), G%HI, tv%eqn_of_state) enddo else do k=1,nz - call calculate_density(tv%T(:,j,k), tv%S(:,j,k), p_ref, Rcv(:,k), G%HI, tv%eqn_of_state, US) + call calculate_density(tv%T(:,j,k), tv%S(:,j,k), p_ref, Rcv(:,k), G%HI, tv%eqn_of_state) enddo endif From 4f42d7278ca6321bccb6b3cbe37d85ff6626256f Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 17 Apr 2020 13:36:09 -0400 Subject: [PATCH 205/316] Fixed the spelling in an openMP directive --- src/parameterizations/lateral/MOM_thickness_diffuse.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/parameterizations/lateral/MOM_thickness_diffuse.F90 b/src/parameterizations/lateral/MOM_thickness_diffuse.F90 index 49d1665b16..1b57cf9ec0 100644 --- a/src/parameterizations/lateral/MOM_thickness_diffuse.F90 +++ b/src/parameterizations/lateral/MOM_thickness_diffuse.F90 @@ -757,7 +757,7 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV !$OMP I_slope_max2,h_neglect2,present_int_slope_u, & !$OMP int_slope_u,KH_u,uhtot,h_frac,h_avail_rsum, & !$OMP uhD,h_avail,G_scale,Work_u,CS,slope_x,cg1, & -!$OMP diag_sfn_x, diag_sfn_unlim_x,N2_floor,EOS_dom_u, & +!$OMP diag_sfn_x, diag_sfn_unlim_x,N2_floor,EOSdom_u, & !$OMP present_slope_x,G_rho0,Slope_x_PE,hN2_x_PE) & !$OMP private(drdiA,drdiB,drdkL,drdkR,pres_u,T_u,S_u, & !$OMP drho_dT_u,drho_dS_u,hg2A,hg2B,hg2L,hg2R,haA, & From 0caf9ccabee4f0c9a351ddc6868c263eedf99c45 Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Fri, 17 Apr 2020 18:56:35 +0000 Subject: [PATCH 206/316] Missed a conflict resolution --- src/equation_of_state/MOM_EOS.F90 | 41 ++++++++++++++----------------- 1 file changed, 18 insertions(+), 23 deletions(-) diff --git a/src/equation_of_state/MOM_EOS.F90 b/src/equation_of_state/MOM_EOS.F90 index e74ace5de8..0623f955cf 100644 --- a/src/equation_of_state/MOM_EOS.F90 +++ b/src/equation_of_state/MOM_EOS.F90 @@ -607,7 +607,7 @@ end subroutine calculate_density_derivs_array !> Calls the appropriate subroutine to calculate density derivatives for 1-D array inputs. -subroutine calculate_density_derivs_1d(T, S, pressure, drho_dT, drho_dS, EOS, US, dom, scale) +subroutine calculate_density_derivs_1d(T, S, pressure, drho_dT, drho_dS, EOS, dom, scale) real, dimension(:), intent(in) :: T !< Potential temperature referenced to the surface [degC] real, dimension(:), intent(in) :: S !< Salinity [ppt] real, dimension(:), intent(in) :: pressure !< Pressure [R L2 T-2 ~> Pa] @@ -616,7 +616,6 @@ subroutine calculate_density_derivs_1d(T, S, pressure, drho_dT, drho_dS, EOS, US real, dimension(:), intent(inout) :: drho_dS !< The partial derivative of density with salinity !! [R degC-1 ~> kg m-3 ppt-1] type(EOS_type), pointer :: EOS !< Equation of state structure - type(unit_scale_type), optional, intent(in) :: US !< A dimensional unit scaling type integer, dimension(2), optional, intent(in) :: dom !< The domain of indices to work on, taking !! into account that arrays start at 1. real, optional, intent(in) :: scale !< A multiplicative factor by which to scale density @@ -636,7 +635,7 @@ subroutine calculate_density_derivs_1d(T, S, pressure, drho_dT, drho_dS, EOS, US is = 1 ; ie = size(drho_dT) ; npts = 1 + ie - is endif - p_scale = 1.0 ; if (present(US)) p_scale = US%RL2_T2_to_Pa + p_scale = EOS%RL2_T2_to_Pa if (p_scale == 1.0) then call calculate_density_derivs_array(T, S, pressure, drho_dT, drho_dS, is, npts, EOS) @@ -645,7 +644,7 @@ subroutine calculate_density_derivs_1d(T, S, pressure, drho_dT, drho_dS, EOS, US call calculate_density_derivs_array(T, S, pres, drho_dT, drho_dS, is, npts, EOS) endif - rho_scale = US%kg_m3_to_R + rho_scale = EOS%kg_m3_to_R if (present(scale)) rho_scale = rho_scale * scale if (rho_scale /= 1.0) then ; do i=is,ie drho_dT(i) = rho_scale * drho_dT(i) @@ -897,7 +896,7 @@ end subroutine calculate_spec_vol_derivs_array !> Calls the appropriate subroutine to calculate specific volume derivatives for 1-d array inputs, !! potentially limiting the domain of indices that are worked on. -subroutine calc_spec_vol_derivs_1d(T, S, pressure, dSV_dT, dSV_dS, EOS, US, dom, scale) +subroutine calc_spec_vol_derivs_1d(T, S, pressure, dSV_dT, dSV_dS, EOS, dom, scale) real, dimension(:), intent(in) :: T !< Potential temperature referenced to the surface [degC] real, dimension(:), intent(in) :: S !< Salinity [ppt] real, dimension(:), intent(in) :: pressure !< Pressure [R L2 T-2 ~> Pa] @@ -906,7 +905,6 @@ subroutine calc_spec_vol_derivs_1d(T, S, pressure, dSV_dT, dSV_dS, EOS, US, dom, real, dimension(:), intent(inout) :: dSV_dS !< The partial derivative of specific volume with salinity !! [R-1 ppt-1 ~> m3 kg-1 ppt-1] type(EOS_type), pointer :: EOS !< Equation of state structure - type(unit_scale_type), optional, intent(in) :: US !< A dimensional unit scaling type integer, dimension(2), optional, intent(in) :: dom !< The domain of indices to work on, taking !! into account that arrays start at 1. real, optional, intent(in) :: scale !< A multiplicative factor by which to scale specific @@ -926,7 +924,7 @@ subroutine calc_spec_vol_derivs_1d(T, S, pressure, dSV_dT, dSV_dS, EOS, US, dom, else is = 1 ; ie = size(dSV_dT) ; npts = 1 + ie - is endif - p_scale = 1.0 ; if (present(US)) p_scale = US%RL2_T2_to_Pa + p_scale = EOS%RL2_T2_to_Pa if (p_scale == 1.0) then call calculate_spec_vol_derivs_array(T, S, pressure, dSV_dT, dSV_dS, is, npts, EOS) @@ -935,7 +933,7 @@ subroutine calc_spec_vol_derivs_1d(T, S, pressure, dSV_dT, dSV_dS, EOS, US, dom, call calculate_spec_vol_derivs_array(T, S, press, dSV_dT, dSV_dS, is, npts, EOS) endif - spv_scale = US%R_to_kg_m3 + spv_scale = EOS%R_to_kg_m3 if (present(scale)) spv_scale = spv_scale * scale if (spv_scale /= 1.0) then ; do i=is,ie dSV_dT(i) = spv_scale * dSV_dT(i) @@ -2051,7 +2049,7 @@ end function frac_dp_at_pos !! are parabolic profiles subroutine int_density_dz_generic_ppm(T, T_t, T_b, S, S_t, S_b, & z_t, z_b, rho_ref, rho_0, G_e, HII, HIO, & - EOS, dpa, intz_dpa, intx_dpa, inty_dpa, US) + EOS, dpa, intz_dpa, intx_dpa, inty_dpa) type(hor_index_type), intent(in) :: HII !< Ocean horizontal index structures for the input arrays type(hor_index_type), intent(in) :: HIO !< Ocean horizontal index structures for the output arrays @@ -2091,7 +2089,6 @@ subroutine int_density_dz_generic_ppm(T, T_t, T_b, S, S_t, S_b, & optional, intent(inout) :: 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 [R L2 T-2 ~> Pa] - type(unit_scale_type), optional, intent(in) :: US !< A dimensional unit scaling type ! This subroutine calculates (by numerical quadrature) integrals of ! pressure anomalies across layers, which are required for calculating the @@ -2144,9 +2141,9 @@ subroutine int_density_dz_generic_ppm(T, T_t, T_b, S, S_t, S_b, & is = HIO%isc + ioff ; ie = HIO%iec + ioff js = HIO%jsc + joff ; je = HIO%jec + joff - rho_scale = 1.0 ; if (present(US)) rho_scale = EOS%kg_m3_to_R - GxRho = G_e * rho_0 ; if (present(US)) GxRho = EOS%RL2_T2_to_Pa * G_e * rho_0 - rho_ref_mks = rho_ref ; if (present(US)) rho_ref_mks = rho_ref * EOS%R_to_kg_m3 + rho_scale = EOS%kg_m3_to_R + GxRho = EOS%RL2_T2_to_Pa * G_e * rho_0 + rho_ref_mks = rho_ref * EOS%R_to_kg_m3 I_Rho = 1.0 / rho_0 ! ============================= @@ -2509,7 +2506,7 @@ end subroutine evaluate_shape_quadratic !! 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, & - bathyP, dP_neglect, useMassWghtInterp, US) + 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 !< Potential temperature of the layer [degC] @@ -2547,7 +2544,6 @@ subroutine int_spec_vol_dp_generic(T, S, p_t, p_b, alpha_ref, HI, EOS, dza, & !! the same units as p_t [R L2 T-2 ~> Pa] or [Pa] logical, optional, intent(in) :: useMassWghtInterp !< If true, uses mass weighting !! to interpolate T/S for top and bottom integrals. - type(unit_scale_type), optional, intent(in) :: US !< A dimensional unit scaling type ! This subroutine calculates analytical and nearly-analytical integrals in ! pressure across layers of geopotential anomalies, which are required for @@ -2586,9 +2582,9 @@ subroutine int_spec_vol_dp_generic(T, S, p_t, p_b, alpha_ref, HI, EOS, 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 - SV_scale = 1.0 ; if (present(US)) SV_scale = EOS%R_to_kg_m3 - RL2_T2_to_Pa = 1.0 ; if (present(US)) RL2_T2_to_Pa = EOS%RL2_T2_to_Pa - alpha_ref_mks = alpha_ref ; if (present(US)) alpha_ref_mks = alpha_ref * EOS%kg_m3_to_R + SV_scale = EOS%R_to_kg_m3 + RL2_T2_to_Pa = EOS%RL2_T2_to_Pa + alpha_ref_mks = alpha_ref * EOS%kg_m3_to_R do_massWeight = .false. if (present(useMassWghtInterp)) then ; if (useMassWghtInterp) then @@ -2724,7 +2720,7 @@ end subroutine int_spec_vol_dp_generic !! 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, US) + 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 [degC] @@ -2765,7 +2761,6 @@ subroutine int_spec_vol_dp_generic_plm(T_t, T_b, S_t, S_b, p_t, p_b, alpha_ref, !! by the y grid spacing [L2 T-2 ~> m2 s-2] or [m2 s-2] logical, optional, intent(in) :: useMassWghtInterp !< If true, uses mass weighting !! to interpolate T/S for top and bottom integrals. - type(unit_scale_type), optional, intent(in) :: US !< A dimensional unit scaling type ! This subroutine calculates analytical and nearly-analytical integrals in ! pressure across layers of geopotential anomalies, which are required for @@ -2810,9 +2805,9 @@ subroutine int_spec_vol_dp_generic_plm(T_t, T_b, S_t, S_b, p_t, p_b, alpha_ref, do_massWeight = .false. if (present(useMassWghtInterp)) do_massWeight = useMassWghtInterp - SV_scale = 1.0 ; if (present(US)) SV_scale = EOS%R_to_kg_m3 - RL2_T2_to_Pa = 1.0 ; if (present(US)) RL2_T2_to_Pa = EOS%RL2_T2_to_Pa - alpha_ref_mks = alpha_ref ; if (present(US)) alpha_ref_mks = alpha_ref * EOS%kg_m3_to_R + SV_scale = EOS%R_to_kg_m3 + RL2_T2_to_Pa = EOS%RL2_T2_to_Pa + alpha_ref_mks = alpha_ref * EOS%kg_m3_to_R do n = 1, 5 ! Note that these are reversed from int_density_dz. wt_t(n) = 0.25 * real(n-1) From 371ed85ca4abc1a6c865573cd11bf361393538cd Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Fri, 17 Apr 2020 19:29:12 +0000 Subject: [PATCH 207/316] Initialize scaling params without EOS_init() --- src/equation_of_state/MOM_EOS.F90 | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/src/equation_of_state/MOM_EOS.F90 b/src/equation_of_state/MOM_EOS.F90 index 0623f955cf..034912b9ff 100644 --- a/src/equation_of_state/MOM_EOS.F90 +++ b/src/equation_of_state/MOM_EOS.F90 @@ -115,11 +115,11 @@ module MOM_EOS ! Unit conversion factors (normally used for dimensional testing but could also allow for ! change of units of arguments to functions) - real :: m_to_Z !< A constant that translates distances in meters to the units of depth. - real :: kg_m3_to_R !< A constant that translates kilograms per meter cubed to the units of density. - real :: R_to_kg_m3 !< A constant that translates the units of density to kilograms per meter cubed. - real :: RL2_T2_to_Pa !< Convert pressures from R L2 T-2 to Pa. - real :: L_T_to_m_s !< Convert lateral velocities from L T-1 to m s-1. + real :: m_to_Z = 1. !< A constant that translates distances in meters to the units of depth. + real :: kg_m3_to_R = 1. !< A constant that translates kilograms per meter cubed to the units of density. + real :: R_to_kg_m3 = 1. !< A constant that translates the units of density to kilograms per meter cubed. + real :: RL2_T2_to_Pa = 1.!< Convert pressures from R L2 T-2 to Pa. + real :: L_T_to_m_s = 1. !< Convert lateral velocities from L T-1 to m s-1. ! logical :: test_EOS = .true. ! If true, test the equation of state end type EOS_type From 64901d119f524067474ef5564781cb804160886a Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Fri, 17 Apr 2020 15:33:31 -0600 Subject: [PATCH 208/316] Add optional limiter and fix unit tests --- src/tracer/MOM_lateral_boundary_diffusion.F90 | 168 +++++++++++------- 1 file changed, 100 insertions(+), 68 deletions(-) diff --git a/src/tracer/MOM_lateral_boundary_diffusion.F90 b/src/tracer/MOM_lateral_boundary_diffusion.F90 index 82e0d6a559..537b3e96fa 100644 --- a/src/tracer/MOM_lateral_boundary_diffusion.F90 +++ b/src/tracer/MOM_lateral_boundary_diffusion.F90 @@ -43,6 +43,8 @@ module MOM_lateral_boundary_diffusion integer :: deg !< Degree of polynomial reconstruction integer :: surface_boundary_scheme !< Which boundary layer scheme to use !! 1. ePBL; 2. KPP + logical :: limiter !< Controls wether a flux limiter is applied. + !! Only valid when method = 1. type(remapping_CS) :: remap_CS !< Control structure to hold remapping configuration type(KPP_CS), pointer :: KPP_CSp => NULL() !< KPP control structure needed to get BLD type(energetic_PBL_CS), pointer :: energetic_PBL_CSp => NULL() !< ePBL control structure needed to get BLD @@ -101,6 +103,11 @@ logical function lateral_boundary_diffusion_init(Time, G, param_file, diag, diab "Determine how to apply boundary lateral diffusion of tracers: \n"//& "1. Bulk layer approach \n"//& "2. Along layer approach", default=1) + if (CS%method == 1) then + call get_param(param_file, mdl, "APPLY_LIMITER", CS%limiter, & + "If True, apply a flux limiter in the LBD. This is only available \n"//& + "when LATERAL_BOUNDARY_METHOD=1.", default=.false.) + endif call get_param(param_file, mdl, "LBD_BOUNDARY_EXTRAP", boundary_extrap, & "Use boundary extrapolation in LBD code", & default=.false.) @@ -185,7 +192,7 @@ subroutine lateral_boundary_diffusion(G, GV, US, h, Coef_x, Coef_y, dt, Reg, CS) call fluxes_bulk_method(SURFACE, GV%ke, CS%deg, h(I,j,:), h(I+1,j,:), hbl(I,j), hbl(I+1,j), & G%areaT(I,j), G%areaT(I+1,j), tracer%t(I,j,:), tracer%t(I+1,j,:), & ppoly0_coefs(I,j,:,:), ppoly0_coefs(I+1,j,:,:), ppoly0_E(I,j,:,:), & - ppoly0_E(I+1,j,:,:), remap_method, Coef_x(I,j), uFlx_bulk(I,j), uFlx(I,j,:)) + ppoly0_E(I+1,j,:,:), remap_method, Coef_x(I,j), uFlx_bulk(I,j), uFlx(I,j,:), CS%limiter) endif enddo enddo @@ -195,7 +202,7 @@ subroutine lateral_boundary_diffusion(G, GV, US, h, Coef_x, Coef_y, dt, Reg, CS) call fluxes_bulk_method(SURFACE, GV%ke, CS%deg, h(i,J,:), h(i,J+1,:), hbl(i,J), hbl(i,J+1), & G%areaT(i,J), G%areaT(i,J+1), tracer%t(i,J,:), tracer%t(i,J+1,:), & ppoly0_coefs(i,J,:,:), ppoly0_coefs(i,J+1,:,:), ppoly0_E(i,J,:,:), & - ppoly0_E(i,J+1,:,:), remap_method, Coef_y(i,J), vFlx_bulk(i,J), vFlx(i,J,:)) + ppoly0_E(i,J+1,:,:), remap_method, Coef_y(i,J), vFlx_bulk(i,J), vFlx(i,J,:), CS%limiter) endif enddo enddo @@ -378,7 +385,7 @@ subroutine boundary_k_range(boundary, nk, h, hbl, k_top, zeta_top, k_bot, zeta_b if (hbl == 0.) return if (hbl >= SUM(h(:))) then k_bot = nk - zeta_bot = 0. + zeta_bot = 1. return endif do k=1,nk @@ -394,12 +401,12 @@ subroutine boundary_k_range(boundary, nk, h, hbl, k_top, zeta_top, k_bot, zeta_b k_top = nk zeta_top = 1. k_bot = nk - zeta_bot = 1. + zeta_bot = 0. htot = 0. if (hbl == 0.) return if (hbl >= SUM(h(:))) then k_top = 1 - zeta_top = 0. + zeta_top = 1. return endif do k=nk,1,-1 @@ -556,8 +563,8 @@ subroutine fluxes_bulk_method(boundary, nk, deg, h_L, h_R, hbl_L, hbl_R, area_L, real, intent(in ) :: khtr_u !< Horizontal diffusivities times delta t at U-point [m^2] real, intent( out) :: F_bulk !< The bulk mixed layer lateral flux [m^3 conc] real, dimension(nk), intent( out) :: F_layer !< Layerwise diffusive flux at U-point [m^3 conc] - real, optional, dimension(nk), intent( out) :: F_limit !< The amount of flux not applied due to limiter - !! F_layer(k) - F_max [m^3 conc] + logical, optional, intent(in ) :: F_limit !< If True, apply a limiter + ! Local variables real, dimension(nk) :: h_means !< Calculate the layer-wise harmonic means [m] real :: khtr_avg !< Thickness-weighted diffusivity at the u-point [m^2 s^-1] @@ -578,8 +585,9 @@ subroutine fluxes_bulk_method(boundary, nk, deg, h_L, h_R, hbl_L, hbl_R, area_L, real :: h_work_L, h_work_R !< dummy variables real :: F_max !< The maximum amount of flux that can leave a !! cell [m^3 conc] - logical :: limited !< True if the flux limiter was applied - real :: hfrac, F_bulk_remain + logical :: limiter !< True if flux limiter should be applied + real :: hfrac !< Layer fraction wrt sum of all layers [nondim] + real :: dphi !< tracer gradient [conc m^-3] if (hbl_L == 0. .or. hbl_R == 0.) then F_bulk = 0. @@ -587,6 +595,11 @@ subroutine fluxes_bulk_method(boundary, nk, deg, h_L, h_R, hbl_L, hbl_R, area_L, return endif + limiter = .false. + if (PRESENT(F_limit)) then + limiter = F_limit + endif + ! Calculate vertical indices containing the boundary layer call boundary_k_range(boundary, nk, h_L, hbl_L, k_top_L, zeta_top_L, k_bot_L, zeta_bot_L) call boundary_k_range(boundary, nk, h_R, hbl_R, k_top_R, zeta_top_R, k_bot_R, zeta_bot_R) @@ -601,7 +614,6 @@ subroutine fluxes_bulk_method(boundary, nk, deg, h_L, h_R, hbl_L, hbl_R, area_L, ! GMM, khtr_avg should be computed once khtr is 3D heff = harmonic_mean(hbl_L, hbl_R) F_bulk = -(khtr_u * heff) * (phi_R_avg - phi_L_avg) - F_bulk_remain = F_bulk ! Calculate the layerwise sum of the vertical effective thickness. This is different than the heff calculated ! above, but is used as a way to decompose the fluxes onto the individual layers h_means(:) = 0. @@ -662,47 +674,36 @@ subroutine fluxes_bulk_method(boundary, nk, deg, h_L, h_R, hbl_L, hbl_R, area_L, if (h_means(k) > 0.) then hfrac = h_means(k)*inv_heff F_layer(k) = F_bulk * hfrac - ! limit the flux to 0.2 of the tracer *gradient* - ! Why 0.2? - ! t=0 t=inf - ! 0 .2 - ! 0 1 0 .2.2.2 - ! 0 .2 - ! - F_max = -0.2 * ((area_R*(phi_R(k)*h_R(k)))-(area_L*(phi_L(k)*h_R(k)))) - - ! check if bulk flux (or F_layer) and F_max have same direction - if ( SIGN(1.,F_bulk) == SIGN(1., F_max)) then - ! Distribute bulk flux onto layers - if ( ((boundary == SURFACE) .and. (k == k_min)) .or. ((boundary == BOTTOM) .and. (k == nk)) ) then - F_layer(k) = F_bulk_remain ! GMM, are not using F_bulk_remain for now. Should we keep it? - endif - F_bulk_remain = F_bulk_remain - F_layer(k) - ! Apply flux limiter calculated above - if (F_max >= 0.) then - limited = F_layer(k) > F_max - F_layer(k) = MIN(F_layer(k),F_max) - else - limited = F_layer(k) < F_max - F_layer(k) = MAX(F_layer(k),F_max) - endif - - ! GMM, again we are not using F_limit. Should we delete it? - if (PRESENT(F_limit)) then - if (limited) then - F_limit(k) = F_layer(k) - F_max + if (limiter) then + ! limit the flux to 0.2 of the tracer *gradient* + ! Why 0.2? + ! t=0 t=inf + ! 0 .2 + ! 0 1 0 .2.2.2 + ! 0 .2 + ! + F_max = -0.2 * ((area_R*(phi_R(k)*h_R(k)))-(area_L*(phi_L(k)*h_R(k)))) + + ! check if bulk flux (or F_layer) and F_max have same direction + if ( SIGN(1.,F_bulk) == SIGN(1., F_max)) then + ! Apply flux limiter calculated above + if (F_max >= 0.) then + F_layer(k) = MIN(F_layer(k),F_max) else - F_limit(k) = 0. + F_layer(k) = MAX(F_layer(k),F_max) endif + else + ! do not apply a flux on this layer + F_layer(k) = 0. endif else - ! do not apply a flux on this layer - F_bulk_remain = F_bulk_remain - F_layer(k) - F_layer(k) = 0. - endif - else - F_layer(k) = 0. + dphi = -(phi_R(k) - phi_L(k)) + if (.not. SIGN(1.,F_bulk) == SIGN(1., dphi)) then + ! upgradient, do not apply a flux on this layer + F_layer(k) = 0. + endif + endif ! limited endif enddo endif @@ -746,47 +747,56 @@ logical function near_boundary_unit_tests( verbose ) test_name = 'Surface boundary spans the entire top cell' h_L = (/5.,5./) call boundary_k_range(SURFACE, nk, h_L, 5., k_top, zeta_top, k_bot, zeta_bot) - near_boundary_unit_tests = test_boundary_k_range(k_top, zeta_top, k_bot, zeta_bot, 1, 0., 1, 1., test_name, verbose) + near_boundary_unit_tests = near_boundary_unit_tests .or. & + test_boundary_k_range(k_top, zeta_top, k_bot, zeta_bot, 1, 0., 1, 1., test_name, verbose) test_name = 'Surface boundary spans the entire column' h_L = (/5.,5./) call boundary_k_range(SURFACE, nk, h_L, 10., k_top, zeta_top, k_bot, zeta_bot) - near_boundary_unit_tests = test_boundary_k_range(k_top, zeta_top, k_bot, zeta_bot, 1, 0., 2, 0., test_name, verbose) + near_boundary_unit_tests = near_boundary_unit_tests .or. & + test_boundary_k_range(k_top, zeta_top, k_bot, zeta_bot, 1, 0., 2, 1., test_name, verbose) test_name = 'Bottom boundary spans the entire bottom cell' h_L = (/5.,5./) call boundary_k_range(BOTTOM, nk, h_L, 5., k_top, zeta_top, k_bot, zeta_bot) - near_boundary_unit_tests = test_boundary_k_range(k_top, zeta_top, k_bot, zeta_bot, 2, 0., 2, 1., test_name, verbose) + near_boundary_unit_tests = near_boundary_unit_tests .or. & + test_boundary_k_range(k_top, zeta_top, k_bot, zeta_bot, 2, 1., 2, 0., test_name, verbose) test_name = 'Bottom boundary spans the entire column' h_L = (/5.,5./) call boundary_k_range(BOTTOM, nk, h_L, 10., k_top, zeta_top, k_bot, zeta_bot) - near_boundary_unit_tests = test_boundary_k_range(k_top, zeta_top, k_bot, zeta_bot, 1, 0., 2, 1., test_name, verbose) + near_boundary_unit_tests = near_boundary_unit_tests .or. & + test_boundary_k_range(k_top, zeta_top, k_bot, zeta_bot, 1, 1., 2, 0., test_name, verbose) test_name = 'Surface boundary intersects second layer' h_L = (/10.,10./) call boundary_k_range(SURFACE, nk, h_L, 17.5, k_top, zeta_top, k_bot, zeta_bot) - near_boundary_unit_tests = test_boundary_k_range(k_top, zeta_top, k_bot, zeta_bot, 1, 0., 2, 0.75, test_name, verbose) + near_boundary_unit_tests = near_boundary_unit_tests .or. & + test_boundary_k_range(k_top, zeta_top, k_bot, zeta_bot, 1, 0., 2, 0.75, test_name, verbose) test_name = 'Surface boundary intersects first layer' h_L = (/10.,10./) call boundary_k_range(SURFACE, nk, h_L, 2.5, k_top, zeta_top, k_bot, zeta_bot) - near_boundary_unit_tests = test_boundary_k_range(k_top, zeta_top, k_bot, zeta_bot, 1, 0., 1, 0.25, test_name, verbose) + near_boundary_unit_tests = near_boundary_unit_tests .or. & + test_boundary_k_range(k_top, zeta_top, k_bot, zeta_bot, 1, 0., 1, 0.25, test_name, verbose) test_name = 'Surface boundary is deeper than column thickness' h_L = (/10.,10./) call boundary_k_range(SURFACE, nk, h_L, 21.0, k_top, zeta_top, k_bot, zeta_bot) - near_boundary_unit_tests = test_boundary_k_range(k_top, zeta_top, k_bot, zeta_bot, 1, 0., 2, 0., test_name, verbose) + near_boundary_unit_tests = near_boundary_unit_tests .or. & + test_boundary_k_range(k_top, zeta_top, k_bot, zeta_bot, 1, 0., 2, 1., test_name, verbose) test_name = 'Bottom boundary intersects first layer' h_L = (/10.,10./) call boundary_k_range(BOTTOM, nk, h_L, 17.5, k_top, zeta_top, k_bot, zeta_bot) - near_boundary_unit_tests = test_boundary_k_range(k_top, zeta_top, k_bot, zeta_bot, 1, 0.75, 2, 1., test_name, verbose) + near_boundary_unit_tests = near_boundary_unit_tests .or. & + test_boundary_k_range(k_top, zeta_top, k_bot, zeta_bot, 1, 0.75, 2, 0., test_name, verbose) test_name = 'Bottom boundary intersects second layer' h_L = (/10.,10./) call boundary_k_range(BOTTOM, nk, h_L, 2.5, k_top, zeta_top, k_bot, zeta_bot) - near_boundary_unit_tests = test_boundary_k_range(k_top, zeta_top, k_bot, zeta_bot, 2, 0.25, 2, 1., test_name, verbose) + near_boundary_unit_tests = near_boundary_unit_tests .or. & + test_boundary_k_range(k_top, zeta_top, k_bot, zeta_bot, 2, 0.25, 2, 0., test_name, verbose) ! All cases in this section have hbl which are equal to the column thicknesses test_name = 'Equal hbl and same layer thicknesses (gradient from right to left)' @@ -802,9 +812,17 @@ logical function near_boundary_unit_tests( verbose ) ppoly0_E_R(1,1) = 1.; ppoly0_E_R(1,2) = 1. ppoly0_E_R(2,1) = 1.; ppoly0_E_R(2,2) = 1. khtr_u = 1. + ! Without limiter call fluxes_bulk_method(SURFACE, nk, deg, h_L, h_R, hbl_L, hbl_R, area_L, area_R, phi_L, phi_R, phi_pp_L, phi_pp_R, & ppoly0_E_L, ppoly0_E_R, method, khtr_u, F_bulk, F_layer) - near_boundary_unit_tests = test_layer_fluxes( verbose, nk, test_name, F_layer, (/-5.0,-5.0/) ) + near_boundary_unit_tests = near_boundary_unit_tests .or. & + test_layer_fluxes( verbose, nk, test_name, F_layer, (/-5.0,-5.0/) ) + + ! same as above, but with limiter + call fluxes_bulk_method(SURFACE, nk, deg, h_L, h_R, hbl_L, hbl_R, area_L, area_R, phi_L, phi_R, phi_pp_L, phi_pp_R, & + ppoly0_E_L, ppoly0_E_R, method, khtr_u, F_bulk, F_layer, .true.) + near_boundary_unit_tests = near_boundary_unit_tests .or. & + test_layer_fluxes( verbose, nk, test_name, F_layer, (/-1.0,-1.0/) ) test_name = 'Equal hbl and same layer thicknesses (gradient from left to right)' hbl_L = 10.; hbl_R = 10. @@ -821,7 +839,8 @@ logical function near_boundary_unit_tests( verbose ) khtr_u = 1. call fluxes_bulk_method(SURFACE, nk, deg, h_L, h_R, hbl_L, hbl_R, area_L, area_R, phi_L, phi_R, phi_pp_L, phi_pp_R,& ppoly0_E_L, ppoly0_E_R, method, khtr_u, F_bulk, F_layer) - near_boundary_unit_tests = test_layer_fluxes( verbose, nk, test_name, F_layer, (/5.0,5.0/) ) + near_boundary_unit_tests = near_boundary_unit_tests .or. & + test_layer_fluxes( verbose, nk, test_name, F_layer, (/5.0,5.0/) ) test_name = 'Equal hbl and same layer thicknesses (no gradient)' hbl_L = 10; hbl_R = 10 @@ -831,14 +850,15 @@ logical function near_boundary_unit_tests( verbose ) phi_pp_L(2,1) = 1.; phi_pp_L(2,2) = 0. phi_pp_R(1,1) = 1.; phi_pp_R(1,2) = 0. phi_pp_R(2,1) = 1.; phi_pp_R(2,2) = 0. - ppoly0_E_L(1,1) = 1.; ppoly0_E_L(1,2) = 0. - ppoly0_E_L(2,1) = 1.; ppoly0_E_L(2,2) = 0. + ppoly0_E_L(1,1) = 1.; ppoly0_E_L(1,2) = 1. + ppoly0_E_L(2,1) = 1.; ppoly0_E_L(2,2) = 1. ppoly0_E_R(1,1) = 1.; ppoly0_E_R(1,2) = 1. ppoly0_E_R(2,1) = 1.; ppoly0_E_R(2,2) = 1. khtr_u = 1. call fluxes_bulk_method(SURFACE, nk, deg, h_L, h_R, hbl_L, hbl_R, area_L, area_R, phi_L, phi_R, phi_pp_L, phi_pp_R,& ppoly0_E_L, ppoly0_E_R, method, khtr_u, F_bulk, F_layer) - near_boundary_unit_tests = test_layer_fluxes( verbose, nk, test_name, F_layer, (/0.0,0.0/) ) + near_boundary_unit_tests = near_boundary_unit_tests .or. & + test_layer_fluxes( verbose, nk, test_name, F_layer, (/0.0,0.0/) ) test_name = 'Equal hbl and different layer thicknesses (gradient right to left)' hbl_L = 16.; hbl_R = 16. @@ -855,7 +875,8 @@ logical function near_boundary_unit_tests( verbose ) khtr_u = 1. call fluxes_bulk_method(SURFACE, nk, deg, h_L, h_R, hbl_L, hbl_R, area_L, area_R, phi_L, phi_R, phi_pp_L, phi_pp_R,& ppoly0_E_L, ppoly0_E_R, method, khtr_u, F_bulk, F_layer) - near_boundary_unit_tests = test_layer_fluxes( verbose, nk, test_name, F_layer, (/-8.0,-8.0/) ) + near_boundary_unit_tests = near_boundary_unit_tests .or. & + test_layer_fluxes( verbose, nk, test_name, F_layer, (/-8.0,-8.0/) ) test_name = 'Equal hbl and same layer thicknesses (diagonal tracer values)' hbl_L = 10.; hbl_R = 10. @@ -872,7 +893,8 @@ logical function near_boundary_unit_tests( verbose ) khtr_u = 1. call fluxes_bulk_method(SURFACE, nk, deg, h_L, h_R, hbl_L, hbl_R, area_L, area_R, phi_L, phi_R, phi_pp_L, phi_pp_R,& ppoly0_E_L, ppoly0_E_R, method, khtr_u, F_bulk, F_layer) - near_boundary_unit_tests = test_layer_fluxes( verbose, nk, test_name, F_layer, (/0.0,0.0/) ) + near_boundary_unit_tests = near_boundary_unit_tests .or. & + test_layer_fluxes( verbose, nk, test_name, F_layer, (/0.0,0.0/) ) test_name = 'Different hbl and different layer thicknesses (gradient from right to left)' hbl_L = 12; hbl_R = 20 @@ -889,7 +911,8 @@ logical function near_boundary_unit_tests( verbose ) khtr_u = 1. call fluxes_bulk_method(SURFACE, nk, deg, h_L, h_R, hbl_L, hbl_R, area_L, area_R, phi_L, phi_R, phi_pp_L, phi_pp_R,& ppoly0_E_L, ppoly0_E_R, method, khtr_u, F_bulk, F_layer) - near_boundary_unit_tests = test_layer_fluxes( verbose, nk, test_name, F_layer, (/-7.5,-7.5/) ) + near_boundary_unit_tests = near_boundary_unit_tests .or. & + test_layer_fluxes( verbose, nk, test_name, F_layer, (/-7.5,-7.5/) ) ! Cases where hbl < column thickness (polynomial coefficients specified for pseudo-linear reconstruction) @@ -901,10 +924,15 @@ logical function near_boundary_unit_tests( verbose ) phi_pp_L(2,1) = 0.; phi_pp_L(2,2) = 0. phi_pp_R(1,1) = 1.; phi_pp_R(1,2) = 0. phi_pp_R(2,1) = 1.; phi_pp_R(2,2) = 0. + ppoly0_E_L(1,1) = 0.; ppoly0_E_L(1,2) = 0. + ppoly0_E_L(2,1) = 0.; ppoly0_E_L(2,2) = 0. + ppoly0_E_R(1,1) = 1.; ppoly0_E_R(1,2) = 1. + ppoly0_E_R(2,1) = 1.; ppoly0_E_R(2,2) = 1. khtr_u = 1. call fluxes_bulk_method(SURFACE, nk, deg, h_L, h_R, hbl_L, hbl_R, area_L, area_R, phi_L, phi_R, phi_pp_L, phi_pp_R,& ppoly0_E_L, ppoly0_E_R, method, khtr_u, F_bulk, F_layer) - near_boundary_unit_tests = test_layer_fluxes( verbose, nk, test_name, F_layer, (/-1.,-1./) ) + near_boundary_unit_tests = near_boundary_unit_tests .or. & + test_layer_fluxes( verbose, nk, test_name, F_layer, (/-1.,-1./) ) test_name = 'hbl < column thickness, hbl same, linear profile right' hbl_L = 2; hbl_R = 2 @@ -921,7 +949,8 @@ logical function near_boundary_unit_tests( verbose ) ppoly0_E_R(2,1) = 1.; ppoly0_E_R(2,2) = 3. call fluxes_bulk_method(SURFACE, nk, deg, h_L, h_R, hbl_L, hbl_R, area_L, area_R, phi_L, phi_R, phi_pp_L, phi_pp_R,& ppoly0_E_L, ppoly0_E_R, method, khtr_u, F_bulk, F_layer) - near_boundary_unit_tests = test_layer_fluxes( verbose, nk, test_name, F_layer, (/-1.,-1./) ) + near_boundary_unit_tests = near_boundary_unit_tests .or. & + test_layer_fluxes( verbose, nk, test_name, F_layer, (/-1.,-1./) ) test_name = 'hbl < column thickness, hbl same, linear profile right, khtr=2' hbl_L = 2; hbl_R = 2 @@ -938,7 +967,8 @@ logical function near_boundary_unit_tests( verbose ) ppoly0_E_R(2,1) = 1.; ppoly0_E_R(2,2) = 3. call fluxes_layer_method(SURFACE, nk, deg, h_L, h_R, hbl_L, hbl_R, area_L, area_R, phi_L, phi_R, phi_pp_L, & phi_pp_R, ppoly0_E_L, ppoly0_E_R, method, khtr_u, F_layer) - near_boundary_unit_tests = test_layer_fluxes( verbose, nk, test_name, F_layer, (/-2.,-2./) ) + near_boundary_unit_tests = near_boundary_unit_tests .or. & + test_layer_fluxes( verbose, nk, test_name, F_layer, (/-1.,-3./) ) ! unit tests for layer by layer method test_name = 'Different hbl and different column thicknesses (gradient from right to left)' @@ -956,7 +986,8 @@ logical function near_boundary_unit_tests( verbose ) khtr_u = 1. call fluxes_layer_method(SURFACE, nk, deg, h_L, h_R, hbl_L, hbl_R, area_L, area_R, phi_L, phi_R, phi_pp_L, & phi_pp_R, ppoly0_E_L, ppoly0_E_R, method, khtr_u, F_layer) - near_boundary_unit_tests = test_layer_fluxes( verbose, nk, test_name, F_layer, (/-7.5,0.0/) ) + near_boundary_unit_tests = near_boundary_unit_tests .or. & + test_layer_fluxes( verbose, nk, test_name, F_layer, (/-7.5,-7.5/) ) test_name = 'Different hbl and different column thicknesses (linear profile right)' @@ -974,7 +1005,8 @@ logical function near_boundary_unit_tests( verbose ) khtr_u = 1. call fluxes_layer_method(SURFACE, nk, deg, h_L, h_R, hbl_L, hbl_R, area_L, area_R, phi_L, phi_R, phi_pp_L, & phi_pp_R, ppoly0_E_L, ppoly0_E_R, method, khtr_u, F_layer) - near_boundary_unit_tests = test_layer_fluxes( verbose, nk, test_name, F_layer, (/-3.75,0.0/) ) + near_boundary_unit_tests = near_boundary_unit_tests .or. & + test_layer_fluxes( verbose, nk, test_name, F_layer, (/-3.75,0.0/) ) end function near_boundary_unit_tests !> Returns true if output of near-boundary unit tests does not match correct computed values From 24314161d936f1bfa02a30ac3ab9efcf03d44ec5 Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Fri, 17 Apr 2020 15:34:40 -0600 Subject: [PATCH 209/316] Fix string continuation syntax --- src/tracer/MOM_tracer_registry.F90 | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/tracer/MOM_tracer_registry.F90 b/src/tracer/MOM_tracer_registry.F90 index 9229074099..236949de46 100644 --- a/src/tracer/MOM_tracer_registry.F90 +++ b/src/tracer/MOM_tracer_registry.F90 @@ -426,12 +426,12 @@ subroutine register_tracer_diagnostics(Reg, h, Time, diag, G, GV, US, use_ALE) trim(flux_units), v_extensive = .true., x_cell_method = 'sum', & conversion=(US%L_to_m**2)*Tr%flux_scale*US%s_to_T) Tr%id_lbd_dfx = register_diag_field("ocean_model", trim(shortnm)//"_lbd_diffx", & - diag%axesCuL, Time, trim(flux_longname)//" diffusive zonal flux from the lateral boundary diffusion "& + diag%axesCuL, Time, trim(flux_longname)//" diffusive zonal flux from the lateral boundary diffusion "//& "scheme", trim(flux_units), v_extensive = .true., y_cell_method = 'sum', & conversion=(US%L_to_m**2)*Tr%flux_scale*US%s_to_T) Tr%id_lbd_dfy = register_diag_field("ocean_model", trim(shortnm)//"_lbd_diffy", & - diag%axesCvL, Time, trim(flux_longname)//" diffusive meridional flux from the lateral boundary diffusion"& - " scheme", trim(flux_units), v_extensive = .true., x_cell_method = 'sum', & + diag%axesCvL, Time, trim(flux_longname)//" diffusive meridional flux from the lateral boundary diffusion "//& + "scheme", trim(flux_units), v_extensive = .true., x_cell_method = 'sum', & conversion=(US%L_to_m**2)*Tr%flux_scale*US%s_to_T) else Tr%id_adx = register_diag_field("ocean_model", trim(shortnm)//"_adx", & From b609dead273f162d47f4d80d4062d56e59fb4232 Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Fri, 17 Apr 2020 16:41:09 -0600 Subject: [PATCH 210/316] Fix indices in KE calculation Hoping this will fix the floating point exception in symmetric mode. --- src/parameterizations/lateral/MOM_hor_visc.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/parameterizations/lateral/MOM_hor_visc.F90 b/src/parameterizations/lateral/MOM_hor_visc.F90 index 1458706316..e18b626c37 100644 --- a/src/parameterizations/lateral/MOM_hor_visc.F90 +++ b/src/parameterizations/lateral/MOM_hor_visc.F90 @@ -1073,7 +1073,7 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, endif if (CS%Re_Ah > 0.0) then - KE = 0.125*((u(I,j,k)+u(I,j+1,k))**2 + (v(i,J,k)+v(i+1,J,k))**2) + KE = 0.125*((u(I,j,k)+u(I-1,j,k))**2 + (v(i,J,k)+v(i,J-1,k))**2) Ah = sqrt(KE) * CS%Re_Ah_const_xy(i,j) endif From 9b53927c1fec2d76b4c62096f3c0cafcbeea072d Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 17 Apr 2020 19:52:15 -0400 Subject: [PATCH 211/316] Rescaled internal MOM_CVMix variables Applied dimensional rescaling to many of the internal calculations in the 4 MOM_CVMix files, although calls to external CVMix routines still use the original MKS units. These changes include rescaling of the input and output variables associated with the calculate_density routines. All answers are bitwise identical. --- .../vertical/MOM_CVMix_KPP.F90 | 110 +++--------------- .../vertical/MOM_CVMix_conv.F90 | 19 +-- .../vertical/MOM_CVMix_ddiff.F90 | 34 +++--- .../vertical/MOM_CVMix_shear.F90 | 54 +++++---- 4 files changed, 75 insertions(+), 142 deletions(-) diff --git a/src/parameterizations/vertical/MOM_CVMix_KPP.F90 b/src/parameterizations/vertical/MOM_CVMix_KPP.F90 index 4eaf895d9b..cda63cc70e 100644 --- a/src/parameterizations/vertical/MOM_CVMix_KPP.F90 +++ b/src/parameterizations/vertical/MOM_CVMix_KPP.F90 @@ -148,7 +148,7 @@ module MOM_CVMix_KPP real, allocatable, dimension(:,:) :: kOBL !< Level (+fraction) of OBL extent real, allocatable, dimension(:,:) :: OBLdepthprev !< previous Depth (positive) of OBL [m] real, allocatable, dimension(:,:) :: La_SL !< Langmuir number used in KPP - real, allocatable, dimension(:,:,:) :: dRho !< Bulk difference in density [kg m-3] + real, allocatable, dimension(:,:,:) :: dRho !< Bulk difference in density [R ~> kg m-3] real, allocatable, dimension(:,:,:) :: Uz2 !< Square of bulk difference in resolved velocity [m2 s-2] real, allocatable, dimension(:,:,:) :: BulkRi !< Bulk Richardson number for each layer (dimensionless) real, allocatable, dimension(:,:,:) :: sigma !< Sigma coordinate (dimensionless) @@ -188,7 +188,7 @@ logical function KPP_init(paramFile, G, GV, US, diag, Time, CS, passive, Waves) type(wave_parameters_CS), optional, pointer :: Waves !< Wave CS ! Local variables -#include "version_variable.h" +# include "version_variable.h" 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 @@ -475,7 +475,8 @@ logical function KPP_init(paramFile, G, GV, US, diag, Time, CS, passive, Waves) cmor_units='m', cmor_standard_name='Ocean Mixed Layer Thickness Defined by Mixing Scheme') endif CS%id_BulkDrho = register_diag_field('ocean_model', 'KPP_BulkDrho', diag%axesTL, Time, & - 'Bulk difference in density used in Bulk Richardson number, as used by [CVMix] KPP', 'kg/m3') + 'Bulk difference in density used in Bulk Richardson number, as used by [CVMix] KPP', & + 'kg/m3', conversion=US%R_to_kg_m3) CS%id_BulkUz2 = register_diag_field('ocean_model', 'KPP_BulkUz2', diag%axesTL, Time, & 'Square of bulk difference in resolved velocity used in Bulk Richardson number via [CVMix] KPP', 'm2/s2') CS%id_BulkRi = register_diag_field('ocean_model', 'KPP_BulkRi', diag%axesTL, Time, & @@ -908,20 +909,21 @@ subroutine KPP_compute_BLD(CS, G, GV, US, h, Temp, Salt, u, v, EOS, uStar, buoyF 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 [s-2] real, dimension( G%ke ) :: Ws_1d ! Profile of vertical velocity scale for scalars [m s-1] - real, dimension( G%ke ) :: deltaRho ! delta Rho in numerator of Bulk Ri number + real, dimension( G%ke ) :: deltaRho ! delta Rho in numerator of Bulk Ri number [R ~> kg m-3] real, dimension( G%ke ) :: deltaU2 ! square of delta U (shear) in denominator of Bulk Ri [m2 s-2] real, dimension( G%ke ) :: surfBuoyFlux2 real, dimension( G%ke ) :: BulkRi_1d ! Bulk Richardson number for each layer ! for EOS calculation - real, dimension( 3*G%ke ) :: rho_1D - real, dimension( 3*G%ke ) :: pres_1D + real, dimension( 3*G%ke ) :: rho_1D ! A column of densities [R ~> kg m-3] + real, dimension( 3*G%ke ) :: pres_1D ! A column of pressures [R L2 T-2 ~> Pa] real, dimension( 3*G%ke ) :: Temp_1D real, dimension( 3*G%ke ) :: Salt_1D real :: surfFricVel, surfBuoyFlux, Coriolis - real :: GoRho ! Gravitational acceleration divided by density in MKS units [m4 s-2] - real :: pRef, rho1, rhoK, Uk, Vk, sigma, sigmaRatio + real :: GoRho ! Gravitational acceleration divided by density in MKS units [m R-1 s-2 ~> m4 kg-1 s-2] + real :: pRef ! The interface pressure [R L2 T-2 ~> Pa] + real :: rho1, rhoK, Uk, Vk, sigma, sigmaRatio real :: zBottomMinusOffset ! Height of bottom plus a little bit [m] real :: SLdepth_0d ! Surface layer depth = surf_layer_ext*OBLdepth. @@ -958,7 +960,7 @@ subroutine KPP_compute_BLD(CS, G, GV, US, h, Temp, Salt, u, v, EOS, uStar, buoyF #endif ! some constants - GoRho = GV%mks_g_Earth / (US%R_to_kg_m3*GV%Rho0) + GoRho = GV%mks_g_Earth / GV%Rho0 buoy_scale = US%L_to_m**2*US%s_to_T**3 ! loop over horizontal points on processor @@ -1084,9 +1086,9 @@ subroutine KPP_compute_BLD(CS, G, GV, US, h, Temp, Salt, u, v, EOS, uStar, buoyF 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. + ! pRef is pressure at interface between k and km1 [R L2 T-2 ~> Pa]. ! iterate pRef for next pass through k-loop. - pRef = pRef + GV%H_to_Pa * h(i,j,k) + pRef = pRef + (GV%g_Earth * GV%H_to_RZ) * h(i,j,k) ! this difference accounts for penetrating SW surfBuoyFlux2(k) = buoy_scale * (buoyFlux(i,j,1) - buoyFlux(i,j,k+1)) @@ -1102,7 +1104,7 @@ subroutine KPP_compute_BLD(CS, G, GV, US, h, Temp, Salt, u, v, EOS, uStar, buoyF ! compute in-situ density - call calculate_density(Temp_1D, Salt_1D, pres_1D, rho_1D, 1, 3*G%ke, EOS) + call calculate_density(Temp_1D, Salt_1D, pres_1D, rho_1D, EOS, US) ! N2 (can be negative) and N (non-negative) on interfaces. ! deltaRho is non-local rho difference used for bulk Richardson number. @@ -1215,86 +1217,6 @@ subroutine KPP_compute_BLD(CS, G, GV, US, h, Temp, Salt, u, v, EOS, uStar, buoyF 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) ) -!************************************************************************* -! smg: remove code below - -! Following "correction" step has been found to be unnecessary. -! Code should be removed after further testing. -! 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*US%L_T_to_m_s*(u(i,j,1)+u(i-1,j,1)) ; surfHu = surfU * hTot - ! surfV = 0.5*US%L_T_to_m_s*(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*US%L_T_to_m_s*(u(i,j,k)+u(i-1,j,k)) - surfU - ! Vk = 0.5*US%L_T_to_m_s*(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*US%L_T_to_m_s*(u(i,j,k)+u(i-1,j,k)) * delH ; surfU = surfHu / hTot - ! surfHv = surfHv + 0.5*US%L_T_to_m_s*(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) [s-1] - ! deltaU2, & ! Square of resolved velocity difference [m2 s-2] - ! ws_cntr=Ws_1d, & ! Turbulent velocity scale profile [m s-1] - ! N_iface=CS%N ) ! Buoyancy frequency [s-1] - - ! surfBuoyFlux = buoy_scale*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-1] - ! surf_buoy=surfBuoyFlux, & ! (in) Buoyancy flux at surface [m2 s-3] - ! Coriolis=Coriolis, & ! (in) Coriolis parameter [s-1] - ! 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 @@ -1359,7 +1281,7 @@ subroutine KPP_smooth_BLD(CS,G,GV,h) 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 +!### real :: pref integer :: i, j, k, s do s=1,CS%n_smooth @@ -1378,7 +1300,7 @@ subroutine KPP_smooth_BLD(CS,G,GV,h) if (G%mask2dT(i,j)==0.) cycle iFaceHeight(1) = 0.0 ! BBL is all relative to the surface - pRef = 0. +!### pRef = 0. hcorr = 0. do k=1,G%ke diff --git a/src/parameterizations/vertical/MOM_CVMix_conv.F90 b/src/parameterizations/vertical/MOM_CVMix_conv.F90 index ce6a40dad2..08ef5e8283 100644 --- a/src/parameterizations/vertical/MOM_CVMix_conv.F90 +++ b/src/parameterizations/vertical/MOM_CVMix_conv.F90 @@ -168,11 +168,14 @@ subroutine calculate_CVMix_conv(h, tv, G, GV, US, CS, hbl) real, dimension(SZK_(G)+1) :: iFaceHeight !< Height of interfaces [m] real, dimension(SZK_(G)) :: cellHeight !< Height of cell centers [m] integer :: kOBL !< level of OBL extent - real :: g_o_rho0 ! Gravitational acceleration divided by density in MKS units [m4 s-2] - real :: pref, rhok, rhokm1, dz, dh, hcorr + real :: g_o_rho0 ! Gravitational acceleration divided by density times unit convserion factors + ! [Z s-2 R-1 ~> m4 s-2 kg-1] + real :: pref ! Interface pressures [R L2 T-2 ~> Pa] + real :: rhok, rhokm1 ! In situ densities of the layers above and below at the interface pressure [R ~> kg m-3] + real :: dz, dh, hcorr integer :: i, j, k - g_o_rho0 = GV%mks_g_Earth / (US%R_to_kg_m3*GV%Rho0) + g_o_rho0 = US%L_to_Z**2*US%s_to_T**2 * GV%g_Earth / GV%Rho0 ! initialize dummy variables rho_lwr(:) = 0.0; rho_1d(:) = 0.0 @@ -196,12 +199,12 @@ subroutine calculate_CVMix_conv(h, tv, G, GV, US, CS, hbl) ! Compute Brunt-Vaisala frequency (static stability) on interfaces do k=2,G%ke - ! pRef is pressure at interface between k and km1. - pRef = pRef + GV%H_to_Pa * h(i,j,k) - call calculate_density(tv%t(i,j,k), tv%s(i,j,k), pref, rhok, tv%eqn_of_state) - call calculate_density(tv%t(i,j,k-1), tv%s(i,j,k-1), pref, rhokm1, tv%eqn_of_state) + ! pRef is pressure at interface between k and km1 [R L2 T-2 ~> Pa]. + pRef = pRef + (GV%H_to_RZ*GV%g_Earth) * h(i,j,k) + call calculate_density(tv%t(i,j,k), tv%s(i,j,k), pRef, rhok, tv%eqn_of_state, US=US) + call calculate_density(tv%t(i,j,k-1), tv%s(i,j,k-1), pRef, rhokm1, tv%eqn_of_state, US=US) - dz = ((0.5*(h(i,j,k-1) + h(i,j,k))+GV%H_subroundoff)*GV%H_to_m) + dz = ((0.5*(h(i,j,k-1) + h(i,j,k))+GV%H_subroundoff)*GV%H_to_Z) CS%N2(i,j,k) = g_o_rho0 * (rhok - rhokm1) / dz ! Can be negative enddo diff --git a/src/parameterizations/vertical/MOM_CVMix_ddiff.F90 b/src/parameterizations/vertical/MOM_CVMix_ddiff.F90 index f169147d03..733f7ac64f 100644 --- a/src/parameterizations/vertical/MOM_CVMix_ddiff.F90 +++ b/src/parameterizations/vertical/MOM_CVMix_ddiff.F90 @@ -182,13 +182,13 @@ subroutine compute_ddiff_coeffs(h, tv, G, GV, US, j, Kd_T, Kd_S, CS) ! 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] + dRho_dT, & !< partial derivatives of density wrt temp [R degC-1 ~> kg m-3 degC-1] + dRho_dS, & !< partial derivatives of density wrt saln [R ppt-1 ~> kg m-3 ppt-1] + pres_int, & !< pressure at each interface [R L2 T-2 ~> Pa] temp_int, & !< temp and at interfaces [degC] salt_int, & !< salt at at interfaces [ppt] - alpha_dT, & !< alpha*dT across interfaces - beta_dS, & !< beta*dS across interfaces + alpha_dT, & !< alpha*dT across interfaces [kg m-3] + beta_dS, & !< beta*dS across interfaces [kg m-3] dT, & !< temp. difference between adjacent layers [degC] dS !< salt difference between adjacent layers [ppt] real, dimension(SZK_(G)+1) :: & @@ -197,7 +197,7 @@ subroutine compute_ddiff_coeffs(h, tv, G, GV, US, j, Kd_T, Kd_S, CS) 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 + real :: dh, hcorr integer :: i, k ! initialize dummy variables @@ -219,31 +219,29 @@ subroutine compute_ddiff_coeffs(h, tv, G, GV, US, j, Kd_T, Kd_S, CS) ! skip calling at land points if (G%mask2dT(i,j) == 0.) cycle - pRef = 0. - pres_int(1) = pRef + pres_int(1) = 0. ! 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 + do K=2,G%ke ! pressure at interface - pres_int(k) = pRef + GV%H_to_Pa * h(i,j,k-1) + pres_int(K) = pres_int(K-1) + (GV%g_Earth * GV%H_to_RZ) * 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)) + 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) + 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)) enddo ! k-loop finishes - call calculate_density_derivs(temp_int, salt_int, pres_int, drho_dT, drho_dS, tv%eqn_of_state) + call calculate_density_derivs(temp_int, salt_int, pres_int, drho_dT, drho_dS, tv%eqn_of_state, US) ! 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) + alpha_dT(k) = -1.0*US%R_to_kg_m3*drho_dT(k) * dT(k) + beta_dS(k) = US%R_to_kg_m3*drho_dS(k) * dS(k) enddo if (CS%id_R_rho > 0.0) then diff --git a/src/parameterizations/vertical/MOM_CVMix_shear.F90 b/src/parameterizations/vertical/MOM_CVMix_shear.F90 index 6aa01d50e5..8ab4bc5977 100644 --- a/src/parameterizations/vertical/MOM_CVMix_shear.F90 +++ b/src/parameterizations/vertical/MOM_CVMix_shear.F90 @@ -13,7 +13,7 @@ module MOM_CVMix_shear use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : thermo_var_ptrs use MOM_verticalGrid, only : verticalGrid_type -use MOM_EOS, only : calculate_density, EOS_type +use MOM_EOS, only : calculate_density use CVMix_shear, only : CVMix_init_shear, CVMix_coeffs_shear use MOM_kappa_shear, only : kappa_shear_is_used implicit none ; private @@ -36,8 +36,8 @@ module MOM_CVMix_shear real :: Nu_zero !< LMD94 maximum interior diffusivity real :: KPP_exp !< Exponent of unitless factor of diff. !! for KPP internal shear mixing scheme. - real, allocatable, dimension(:,:,:) :: N2 !< Squared Brunt-Vaisala frequency [s-2] - real, allocatable, dimension(:,:,:) :: S2 !< Squared shear frequency [s-2] + real, allocatable, dimension(:,:,:) :: N2 !< Squared Brunt-Vaisala frequency [T-2 ~> s-2] + real, allocatable, dimension(:,:,:) :: S2 !< Squared shear frequency [T-2 ~> s-2] real, allocatable, dimension(:,:,:) :: ri_grad !< Gradient Richardson number real, allocatable, dimension(:,:,:) :: ri_grad_smooth !< Gradient Richardson number !! after smoothing @@ -73,16 +73,25 @@ subroutine calculate_CVMix_shear(u_H, v_H, h, tv, kd, kv, G, GV, US, CS ) !! call to CVMix_shear_init. ! Local variables integer :: i, j, k, kk, km1 - real :: GoRho ! Gravitational acceleration divided by density in MKS units [m4 s-2] - 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 :: GoRho ! Gravitational acceleration divided by density [Z T-2 R-1 ~> m4 s-2 kg-2] + real :: pref ! Interface pressures [R L2 T-2 ~> Pa] + real :: DU, DV ! Velocity differences [L T-1 ~> m s-1] + real :: DZ ! Grid spacing around an interface [Z ~> m] + real :: N2 ! Buoyancy frequency at an interface [T-2 ~> s-2] + real :: S2 ! Shear squared at an interface [T-2 ~> s-2] + real :: dummy ! A dummy variable [nondim] + real :: dRho ! Buoyancy differences [Z T-2 ~> m s-2] + real, dimension(2*(G%ke)) :: pres_1d ! A column of interface pressures [R L2 T-2 ~> Pa] + real, dimension(2*(G%ke)) :: temp_1d ! A column of temperatures [degC] + real, dimension(2*(G%ke)) :: salt_1d ! A column of salinities [ppt] + real, dimension(2*(G%ke)) :: rho_1d ! A column of densities at interface pressures [R ~> kg m-3] + real, dimension(G%ke+1) :: Ri_Grad !< Gradient Richardson number [nondim] real, dimension(G%ke+1) :: Kvisc !< Vertical viscosity at interfaces [m2 s-1] real, dimension(G%ke+1) :: Kdiff !< Diapycnal diffusivity at interfaces [m2 s-1] - real, parameter :: epsln = 1.e-10 !< Threshold to identify vanished layers + real, parameter :: epsln = 1.e-10 !< Threshold to identify vanished layers [m] ! some constants - GoRho = GV%mks_g_Earth / (US%R_to_kg_m3*GV%Rho0) + GoRho = US%L_to_Z**2 * GV%g_Earth / GV%Rho0 do j = G%jsc, G%jec do i = G%isc, G%iec @@ -108,24 +117,24 @@ subroutine calculate_CVMix_shear(u_H, v_H, h, tv, kd, kv, G, GV, US, CS ) ! 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) + pRef = pRef + (GV%g_Earth * GV%H_to_RZ) * h(i,j,k) enddo ! k-loop finishes - ! compute in-situ density - call calculate_density(Temp_1D, Salt_1D, pres_1D, rho_1D, 1, 2*G%ke, TV%EQN_OF_STATE) + ! compute in-situ density [R ~> kg m-3] + call calculate_density(Temp_1D, Salt_1D, pres_1D, rho_1D, tv%eqn_of_state, US) ! N2 (can be negative) on interface do k = 1, G%ke km1 = max(1, k-1) kk = 2*(k-1) - DU = US%L_T_to_m_s*(u_h(i,j,k) - u_h(i,j,km1)) - DV = US%L_T_to_m_s*(v_h(i,j,k) - v_h(i,j,km1)) - DRHO = (GoRho * (rho_1D(kk+1) - rho_1D(kk+2)) ) - 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-10) + DU = u_h(i,j,k) - u_h(i,j,km1) + DV = v_h(i,j,k) - v_h(i,j,km1) + DRHO = GoRho * (rho_1D(kk+1) - rho_1D(kk+2)) + DZ = (0.5*(h(i,j,km1) + h(i,j,k))+GV%H_subroundoff)*GV%H_to_Z + N2 = DRHO / DZ + S2 = US%L_to_Z**2*(DU*DU+DV*DV)/(DZ*DZ) + Ri_Grad(k) = max(0., N2) / max(S2, 1.e-10*US%T_to_s**2) ! fill 3d arrays, if user asks for diagsnostics if (CS%id_N2 > 0) CS%N2(i,j,k) = N2 @@ -139,8 +148,9 @@ subroutine calculate_CVMix_shear(u_H, v_H, h, tv, kd, kv, G, GV, US, CS ) if (CS%smooth_ri) then ! 1) fill Ri_grad in vanished layers with adjacent value + !### For dimensional consistency, epsln needs to be epsln*GV%m_to_H. do k = 2, G%ke - if (h(i,j,k) .le. epsln) Ri_grad(k) = Ri_grad(k-1) + if (h(i,j,k) <= epsln) Ri_grad(k) = Ri_grad(k-1) enddo Ri_grad(G%ke+1) = Ri_grad(G%ke) @@ -265,13 +275,13 @@ logical function CVMix_shear_init(Time, G, GV, US, param_file, diag, CS) CS%diag => diag CS%id_N2 = register_diag_field('ocean_model', 'N2_shear', diag%axesTi, Time, & - 'Square of Brunt-Vaisala frequency used by MOM_CVMix_shear module', '1/s2') + 'Square of Brunt-Vaisala frequency used by MOM_CVMix_shear module', '1/s2', conversion=US%s_to_T**2) if (CS%id_N2 > 0) then allocate( CS%N2( SZI_(G), SZJ_(G), SZK_(G)+1 ) ) ; CS%N2(:,:,:) = 0. endif CS%id_S2 = register_diag_field('ocean_model', 'S2_shear', diag%axesTi, Time, & - 'Square of vertical shear used by MOM_CVMix_shear module','1/s2') + 'Square of vertical shear used by MOM_CVMix_shear module','1/s2', conversion=US%s_to_T**2) if (CS%id_S2 > 0) then allocate( CS%S2( SZI_(G), SZJ_(G), SZK_(G)+1 ) ) ; CS%S2(:,:,:) = 0. endif From 760dc39609a47f7974066b67d1f590f4c7b5d784 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 17 Apr 2020 19:53:11 -0400 Subject: [PATCH 212/316] +Rescaled variables in coord_adapt Rescaled internal density and pressure variables in coord_adapt, as well as some input parameters. These changes include rescaling of the input and output variables associated with the calculate_density routines. One variable that was being reused with different units has been split into two, and there are new arguments to build_grid_adaptive, build_adapt_column, and init_coord_adapt. All answers in the MOM6-examples test suite are bitwise identical. --- src/ALE/MOM_regridding.F90 | 13 ++++---- src/ALE/coord_adapt.F90 | 67 ++++++++++++++++++++------------------ 2 files changed, 42 insertions(+), 38 deletions(-) diff --git a/src/ALE/MOM_regridding.F90 b/src/ALE/MOM_regridding.F90 index f6791a3b73..8be7824193 100644 --- a/src/ALE/MOM_regridding.F90 +++ b/src/ALE/MOM_regridding.F90 @@ -599,7 +599,7 @@ subroutine initialize_regridding(CS, GV, US, max_depth, param_file, mdl, coord_m call set_regrid_params(CS, adaptTimeRatio=adaptTimeRatio, adaptZoom=adaptZoom, & adaptZoomCoeff=adaptZoomCoeff, adaptBuoyCoeff=adaptBuoyCoeff, adaptAlpha=adaptAlpha, & - adaptDoMin=tmpLogical, adaptDrho0=US%R_to_kg_m3*adaptDrho0) + adaptDoMin=tmpLogical, adaptDrho0=adaptDrho0) endif if (main_parameters .and. coord_is_state_dependent) then @@ -885,7 +885,7 @@ subroutine regridding_main( remapCS, CS, G, GV, h, tv, h_new, dzInterface, frac_ call calc_h_new_by_dz(CS, G, GV, h, dzInterface, h_new) case ( REGRIDDING_ADAPTIVE ) - call build_grid_adaptive(G, GV, h, tv, dzInterface, remapCS, CS) + call build_grid_adaptive(G, GV, G%US, h, tv, dzInterface, remapCS, CS) call calc_h_new_by_dz(CS, G, GV, h, dzInterface, h_new) case default @@ -1527,9 +1527,10 @@ end subroutine build_grid_HyCOM1 !> 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) +subroutine build_grid_adaptive(G, GV, US, 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 + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various !! thermodynamic variables @@ -1575,7 +1576,7 @@ subroutine build_grid_adaptive(G, GV, h, tv, dzInterface, remapCS, CS) cycle endif - call build_adapt_column(CS%adapt_CS, G, GV, tv, i, j, zInt, tInt, sInt, h, zNext) + call build_adapt_column(CS%adapt_CS, G, GV, US, tv, i, j, zInt, tInt, sInt, h, zNext) call filtered_grid_motion(CS, nz, zInt(i,j,:), zNext, dzInterface(i,j,:)) ! convert from depth to z @@ -1990,7 +1991,7 @@ subroutine initCoord(CS, GV, US, coord_mode) call init_coord_slight(CS%slight_CS, CS%nk, CS%ref_pressure, CS%target_density, & CS%interp_CS, GV%m_to_H) case (REGRIDDING_ADAPTIVE) - call init_coord_adapt(CS%adapt_CS, CS%nk, CS%coordinateResolution, GV%m_to_H) + call init_coord_adapt(CS%adapt_CS, CS%nk, CS%coordinateResolution, GV%m_to_H, US%kg_m3_to_R) end select end subroutine initCoord @@ -2272,7 +2273,7 @@ subroutine set_regrid_params( CS, boundary_extrapolation, min_thickness, old_gri !! preventing interfaces from being shallower than !! the depths specified by the regridding coordinate. real, optional, intent(in) :: adaptDrho0 !< Reference density difference for stratification-dependent - !! diffusion. [kg m-3] + !! diffusion. [R ~> kg m-3] 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) diff --git a/src/ALE/coord_adapt.F90 b/src/ALE/coord_adapt.F90 index 3a083af2db..383bf6a055 100644 --- a/src/ALE/coord_adapt.F90 +++ b/src/ALE/coord_adapt.F90 @@ -5,6 +5,7 @@ module coord_adapt use MOM_EOS, only : calculate_density_derivs use MOM_error_handler, only : MOM_error, FATAL +use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : ocean_grid_type, thermo_var_ptrs use MOM_verticalGrid, only : verticalGrid_type @@ -36,7 +37,7 @@ module coord_adapt !> Stratification-dependent diffusion coefficient real :: adaptBuoyCoeff - !> Reference density difference for stratification-dependent diffusion [kg m-3] + !> Reference density difference for stratification-dependent diffusion [R ~> kg m-3] real :: adaptDrho0 !> If true, form a HYCOM1-like mixed layet by preventing interfaces @@ -49,31 +50,28 @@ module coord_adapt contains !> Initialise an adapt_CS with parameters -subroutine init_coord_adapt(CS, nk, coordinateResolution, m_to_H) +subroutine init_coord_adapt(CS, nk, coordinateResolution, m_to_H, kg_m3_to_R) type(adapt_CS), pointer :: CS !< Unassociated pointer to hold the control structure integer, intent(in) :: nk !< Number of layers in the grid real, dimension(:), intent(in) :: coordinateResolution !< Nominal near-surface resolution [m] or !! other units specified with m_to_H - real, optional, intent(in) :: m_to_H !< A conversion factor from m to the units of thicknesses - - real :: m_to_H_rescale ! A unit conversion factor. + real, intent(in) :: m_to_H !< A conversion factor from m to the units of thicknesses + real, intent(in) :: kg_m3_to_R !< A conversion factor from kg m-3 to the units of density if (associated(CS)) call MOM_error(FATAL, "init_coord_adapt: CS already associated") allocate(CS) allocate(CS%coordinateResolution(nk)) - m_to_H_rescale = 1.0 ; if (present(m_to_H)) m_to_H_rescale = m_to_H - CS%nk = nk CS%coordinateResolution(:) = coordinateResolution(:) ! Set real parameter default values CS%adaptTimeRatio = 1e-1 ! Nondim. CS%adaptAlpha = 1.0 ! Nondim. - CS%adaptZoom = 200.0 * m_to_H_rescale + CS%adaptZoom = 200.0 * m_to_H ! [H ~> m or kg m-2] CS%adaptZoomCoeff = 0.0 ! Nondim. CS%adaptBuoyCoeff = 0.0 ! Nondim. - CS%adaptDrho0 = 0.5 ! [kg m-3] + CS%adaptDrho0 = 0.5 * kg_m3_to_R ! [R ~> kg m-3] end subroutine init_coord_adapt @@ -98,7 +96,7 @@ subroutine set_adapt_params(CS, adaptTimeRatio, adaptAlpha, adaptZoom, adaptZoom 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 + !! stratification-dependent diffusion [R ~> kg m-3] 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 @@ -114,10 +112,11 @@ subroutine set_adapt_params(CS, adaptTimeRatio, adaptAlpha, adaptZoom, adaptZoom if (present(adaptDoMin)) CS%adaptDoMin = adaptDoMin end subroutine set_adapt_params -subroutine build_adapt_column(CS, G, GV, tv, i, j, zInt, tInt, sInt, h, zNext) +subroutine build_adapt_column(CS, G, GV, US, tv, i, j, zInt, tInt, sInt, h, zNext) 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(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various !! thermodynamic variables integer, intent(in) :: i !< The i-index of the column to work on @@ -130,8 +129,12 @@ subroutine build_adapt_column(CS, G, GV, tv, i, j, zInt, tInt, sInt, h, zNext) ! Local variables integer :: k, nz - real :: h_up, b1, b_denom_1, d1, depth, drdz, nominal_z, stretching - real, dimension(SZK_(GV)+1) :: alpha, beta, del2sigma ! drho/dT and drho/dS + real :: h_up, b1, b_denom_1, d1, depth, nominal_z, stretching + real :: drdz ! The vertical density gradient [R H-1 ~> kg m-4 or m-1] + real, dimension(SZK_(GV)+1) :: alpha ! drho/dT [R degC-1 ~> kg m-3 degC-1] + real, dimension(SZK_(GV)+1) :: beta ! drho/dS [R ppt-1 ~> kg m-3 ppt-1] + real, dimension(SZK_(GV)+1) :: del2sigma ! Laplacian of in situ density times grid spacing [R ~> kg m-3] + real, dimension(SZK_(GV)+1) :: dh_d2s ! Thickness change in response to del2sigma [H ~> m or kg m-2] real, dimension(SZK_(GV)) :: kGrid, c1 ! grid diffusivity on layers, and tridiagonal work array nz = CS%nk @@ -143,8 +146,8 @@ subroutine build_adapt_column(CS, G, GV, tv, i, j, zInt, tInt, sInt, h, zNext) ! local depth for scaling diffusivity depth = G%bathyT(i,j) * GV%Z_to_H - ! initialize del2sigma to zero - del2sigma(:) = 0. + ! initialize del2sigma and the thickness change response to it zero + del2sigma(:) = 0.0 ; dh_d2s(:) = 0.0 ! calculate del-squared of neutral density by a ! stencilled finite difference @@ -155,8 +158,8 @@ subroutine build_adapt_column(CS, G, GV, tv, i, j, zInt, tInt, sInt, h, zNext) call calculate_density_derivs( & 0.5 * (tInt(i,j,2:nz) + tInt(i,j-1,2:nz)), & 0.5 * (sInt(i,j,2:nz) + sInt(i,j-1,2:nz)), & - 0.5 * (zInt(i,j,2:nz) + zInt(i,j-1,2:nz)) * GV%H_to_Pa, & - alpha, beta, tv%eqn_of_state, dom=(/2,nz/)) + 0.5 * (zInt(i,j,2:nz) + zInt(i,j-1,2:nz)) * (GV%H_to_RZ * GV%g_Earth), & + alpha, beta, tv%eqn_of_state, US, dom=(/2,nz/)) del2sigma(2:nz) = del2sigma(2:nz) + & (alpha(2:nz) * (tInt(i,j-1,2:nz) - tInt(i,j,2:nz)) + & @@ -167,8 +170,8 @@ subroutine build_adapt_column(CS, G, GV, tv, i, j, zInt, tInt, sInt, h, zNext) call calculate_density_derivs( & 0.5 * (tInt(i,j,2:nz) + tInt(i,j+1,2:nz)), & 0.5 * (sInt(i,j,2:nz) + sInt(i,j+1,2:nz)), & - 0.5 * (zInt(i,j,2:nz) + zInt(i,j+1,2:nz)) * GV%H_to_Pa, & - alpha, beta, tv%eqn_of_state, dom=(/2,nz/)) + 0.5 * (zInt(i,j,2:nz) + zInt(i,j+1,2:nz)) * (GV%H_to_RZ * GV%g_Earth), & + alpha, beta, tv%eqn_of_state, US, dom=(/2,nz/)) del2sigma(2:nz) = del2sigma(2:nz) + & (alpha(2:nz) * (tInt(i,j+1,2:nz) - tInt(i,j,2:nz)) + & @@ -179,8 +182,8 @@ subroutine build_adapt_column(CS, G, GV, tv, i, j, zInt, tInt, sInt, h, zNext) call calculate_density_derivs( & 0.5 * (tInt(i,j,2:nz) + tInt(i-1,j,2:nz)), & 0.5 * (sInt(i,j,2:nz) + sInt(i-1,j,2:nz)), & - 0.5 * (zInt(i,j,2:nz) + zInt(i-1,j,2:nz)) * GV%H_to_Pa, & - alpha, beta, tv%eqn_of_state, dom=(/2,nz/)) + 0.5 * (zInt(i,j,2:nz) + zInt(i-1,j,2:nz)) * (GV%H_to_RZ * GV%g_Earth), & + alpha, beta, tv%eqn_of_state, US, dom=(/2,nz/)) del2sigma(2:nz) = del2sigma(2:nz) + & (alpha(2:nz) * (tInt(i-1,j,2:nz) - tInt(i,j,2:nz)) + & @@ -191,8 +194,8 @@ subroutine build_adapt_column(CS, G, GV, tv, i, j, zInt, tInt, sInt, h, zNext) call calculate_density_derivs( & 0.5 * (tInt(i,j,2:nz) + tInt(i+1,j,2:nz)), & 0.5 * (sInt(i,j,2:nz) + sInt(i+1,j,2:nz)), & - 0.5 * (zInt(i,j,2:nz) + zInt(i+1,j,2:nz)) * GV%H_to_Pa, & - alpha, beta, tv%eqn_of_state, dom=(/2,nz/)) + 0.5 * (zInt(i,j,2:nz) + zInt(i+1,j,2:nz)) * (GV%H_to_RZ * GV%g_Earth), & + alpha, beta, tv%eqn_of_state, US, dom=(/2,nz/)) del2sigma(2:nz) = del2sigma(2:nz) + & (alpha(2:nz) * (tInt(i+1,j,2:nz) - tInt(i,j,2:nz)) + & @@ -205,23 +208,23 @@ subroutine build_adapt_column(CS, G, GV, tv, i, j, zInt, tInt, sInt, h, zNext) ! ! a positive curvature means we're too light relative to adjacent columns, ! so del2sigma needs to be positive too (push the interface deeper) - call calculate_density_derivs(tInt(i,j,:), sInt(i,j,:), zInt(i,j,:) * GV%H_to_Pa, & - alpha, beta, tv%eqn_of_state, dom=(/1,nz/)) !### This should be (/1,nz+1/) - see 25 lines below. + call calculate_density_derivs(tInt(i,j,:), sInt(i,j,:), zInt(i,j,:) * (GV%H_to_RZ * GV%g_Earth), & + alpha, beta, tv%eqn_of_state, US, dom=(/1,nz/)) !### This should be (/1,nz+1/) - see 25 lines below. do K = 2, nz ! TODO make lower bound here configurable - del2sigma(K) = del2sigma(K) * (0.5 * (h(i,j,k-1) + h(i,j,k))) / & + dh_d2s(K) = del2sigma(K) * (0.5 * (h(i,j,k-1) + h(i,j,k))) / & max(alpha(K) * (tv%T(i,j,k) - tv%T(i,j,k-1)) + & - beta(K) * (tv%S(i,j,k) - tv%S(i,j,k-1)), 1e-20) + beta(K) * (tv%S(i,j,k) - tv%S(i,j,k-1)), 1e-20*US%kg_m3_to_R) ! don't move the interface so far that it would tangle with another ! interface in the direction we're moving (or exceed a Nyquist limit ! that could cause oscillations of the interface) - h_up = merge(h(i,j,k), h(i,j,k-1), del2sigma(K) > 0.) - del2sigma(K) = 0.5 * CS%adaptAlpha * & - sign(min(abs(del2sigma(K)), 0.5 * h_up), del2sigma(K)) + h_up = merge(h(i,j,k), h(i,j,k-1), dh_d2s(K) > 0.) + dh_d2s(K) = 0.5 * CS%adaptAlpha * & + sign(min(abs(del2sigma(K)), 0.5 * h_up), dh_d2s(K)) ! update interface positions so we can diffuse them - zNext(K) = zInt(i,j,K) + del2sigma(K) + zNext(K) = zInt(i,j,K) + dh_d2s(K) enddo ! solve diffusivity equation to smooth grid @@ -233,7 +236,7 @@ subroutine build_adapt_column(CS, G, GV, tv, i, j, zInt, tInt, sInt, h, zNext) do k = 1, nz ! calculate the dr bit of drdz drdz = 0.5 * (alpha(K) + alpha(K+1)) * (tInt(i,j,K+1) - tInt(i,j,K)) + & - 0.5 * (beta(K) + beta(K+1)) * (sInt(i,j,K+1) - sInt(i,j,K)) + 0.5 * (beta(K) + beta(K+1)) * (sInt(i,j,K+1) - sInt(i,j,K)) ! divide by dz from the new interface positions drdz = drdz / (zNext(K) - zNext(K+1) + GV%H_subroundoff) ! don't do weird stuff in unstably-stratified regions From cdeda16d3cdb0921c21cafab1de90f1c15ccf6e3 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sun, 19 Apr 2020 06:11:41 -0400 Subject: [PATCH 213/316] Switched versions of calculate_density in 22 calls Changed to the new interfaces for calculate_density and related calls in 22 places. All answers are bitwise identical. --- src/ALE/MOM_regridding.F90 | 6 ++--- src/ALE/coord_rho.F90 | 2 +- .../MOM_state_initialization.F90 | 2 +- src/tracer/MOM_tracer_Z_init.F90 | 12 +++++----- src/user/ISOMIP_initialization.F90 | 22 +++++++++---------- src/user/benchmark_initialization.F90 | 6 ++--- 6 files changed, 25 insertions(+), 25 deletions(-) diff --git a/src/ALE/MOM_regridding.F90 b/src/ALE/MOM_regridding.F90 index 8be7824193..1586e414c1 100644 --- a/src/ALE/MOM_regridding.F90 +++ b/src/ALE/MOM_regridding.F90 @@ -1890,7 +1890,7 @@ subroutine convective_adjustment(G, GV, h, tv) do j = G%jsc-1,G%jec+1 ; do i = G%isc-1,G%iec+1 ! Compute densities within current water column - call calculate_density( tv%T(i,j,:), tv%S(i,j,:), p_col, densities, tv%eqn_of_state ) + call calculate_density( tv%T(i,j,:), tv%S(i,j,:), p_col, densities, tv%eqn_of_state, US=G%US) ! Repeat restratification until complete do @@ -1909,9 +1909,9 @@ subroutine convective_adjustment(G, GV, h, tv) tv%S(i,j,k) = S1 ; tv%S(i,j,k+1) = S0 h(i,j,k) = h1 ; h(i,j,k+1) = h0 ! Recompute densities at levels k and k+1 - call calculate_density( tv%T(i,j,k), tv%S(i,j,k), p_col(k), densities(k), tv%eqn_of_state) + call calculate_density( tv%T(i,j,k), tv%S(i,j,k), p_col(k), densities(k), tv%eqn_of_state, US=G%US) 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 ) + densities(k+1), tv%eqn_of_state, US=G%US ) stratified = .false. endif enddo ! k diff --git a/src/ALE/coord_rho.F90 b/src/ALE/coord_rho.F90 index 7c6a00e714..d51e94afb9 100644 --- a/src/ALE/coord_rho.F90 +++ b/src/ALE/coord_rho.F90 @@ -250,7 +250,7 @@ subroutine build_rho_column_iteratively(CS, US, remapCS, nz, depth, h, T, S, eqn enddo ! Compute densities within current water column - call calculate_density( T_tmp, S_tmp, pres, densities, 1, nz, eqn_of_state, US=US) + call calculate_density( T_tmp, S_tmp, pres, densities, eqn_of_state, US=US) do k = 1,count_nonzero_layers densities(k) = densities(mapping(k)) diff --git a/src/initialization/MOM_state_initialization.F90 b/src/initialization/MOM_state_initialization.F90 index 76e87aeed2..8e4be1137d 100644 --- a/src/initialization/MOM_state_initialization.F90 +++ b/src/initialization/MOM_state_initialization.F90 @@ -1601,7 +1601,7 @@ subroutine initialize_temp_salt_fit(T, S, G, GV, US, param_file, eqn_of_state, P enddo call calculate_density(T0(1), S0(1), pres(1), rho_guess(1), eqn_of_state, US=US) - call calculate_density_derivs(T0, S0, pres, drho_dT, drho_dS, 1, 1, eqn_of_state, US=US) + call calculate_density_derivs(T0, S0, pres, drho_dT, drho_dS, eqn_of_state, US=US, dom=(/1,1/)) if (fit_salin) then ! A first guess of the layers' temperatures. diff --git a/src/tracer/MOM_tracer_Z_init.F90 b/src/tracer/MOM_tracer_Z_init.F90 index 76ca2dac4a..b171bc3dce 100644 --- a/src/tracer/MOM_tracer_Z_init.F90 +++ b/src/tracer/MOM_tracer_Z_init.F90 @@ -801,9 +801,9 @@ subroutine determine_temperature(temp, salt, R_tgt, p_ref, niter, land_fill, h, adjust_salt = .true. iter_loop: do itt = 1,niter do k=1, nz - call calculate_density(T(:,k), S(:,k), press, rho(:,k), 1, nx, eos, US=US) - call calculate_density_derivs(T(:,k), S(:,k), press, drho_dT(:,k), drho_dS(:,k), 1, nx, & - eos, US=US) + call calculate_density(T(:,k), S(:,k), press, rho(:,k), eos, US=US, dom=(/1,nx/)) + call calculate_density_derivs(T(:,k), S(:,k), press, drho_dT(:,k), drho_dS(:,k), & + eos, US=US, dom=(/1,nx/)) enddo do k=k_start,nz ; do i=1,nx @@ -831,9 +831,9 @@ subroutine determine_temperature(temp, salt, R_tgt, p_ref, niter, land_fill, h, if (adjust_salt .and. old_fit) then ; do itt = 1,niter do k=1, nz - call calculate_density(T(:,k), S(:,k), press, rho(:,k), 1, nx, eos, US=US) - call calculate_density_derivs(T(:,k), S(:,k), press, drho_dT(:,k), drho_dS(:,k), 1, nx, & - eos, US=US) + call calculate_density(T(:,k), S(:,k), press, rho(:,k), eos, US=US, dom=(/1,nx/)) + call calculate_density_derivs(T(:,k), S(:,k), press, drho_dT(:,k), drho_dS(:,k), & + eos, US=US, dom=(/1,nx/)) enddo do k=k_start,nz ; do i=1,nx ! if (abs(rho(i,k)-R_tgt(k))>tol_rho .and. hin(i,k)>h_massless .and. abs(T(i,k)-land_fill) < epsln ) then diff --git a/src/user/ISOMIP_initialization.F90 b/src/user/ISOMIP_initialization.F90 index c189cf0490..2e2980a782 100644 --- a/src/user/ISOMIP_initialization.F90 +++ b/src/user/ISOMIP_initialization.F90 @@ -184,10 +184,10 @@ subroutine ISOMIP_initialize_thickness ( h, G, GV, US, param_file, tv, just_read if (just_read) return ! All run-time parameters have been read, so return. ! Compute min/max density using T_SUR/S_SUR and T_BOT/S_BOT - call calculate_density(t_sur, s_sur, 0.0, rho_sur, tv%eqn_of_state, scale=US%kg_m3_to_R) + call calculate_density(t_sur, s_sur, 0.0, rho_sur, tv%eqn_of_state, US) ! write(mesg,*) 'Surface density is:', rho_sur ! call MOM_mesg(mesg,5) - call calculate_density(t_bot, s_bot, 0.0, rho_bot, tv%eqn_of_state, scale=US%kg_m3_to_R) + call calculate_density(t_bot, s_bot, 0.0, rho_bot, tv%eqn_of_state, US) ! write(mesg,*) 'Bottom density is:', rho_bot ! call MOM_mesg(mesg,5) rho_range = rho_bot - rho_sur @@ -301,10 +301,10 @@ subroutine ISOMIP_initialize_temperature_salinity ( T, S, h, G, GV, US, param_fi call get_param(param_file, mdl, "ISOMIP_S_BOT", s_bot, & "Salinity at the bottom (interface)", units="ppt", default=34.55, do_not_log=just_read) - call calculate_density(t_sur,s_sur,0.0,rho_sur,eqn_of_state, scale=US%kg_m3_to_R) + call calculate_density(t_sur, s_sur, 0.0, rho_sur, eqn_of_state, US) ! write(mesg,*) 'Density in the surface layer:', rho_sur ! call MOM_mesg(mesg,5) - call calculate_density(t_bot,s_bot,0.0,rho_bot,eqn_of_state, scale=US%kg_m3_to_R) + call calculate_density(t_bot, s_bot, 0.0, rho_bot, eqn_of_state, US) ! write(mesg,*) 'Density in the bottom layer::', rho_bot ! call MOM_mesg(mesg,5) @@ -362,7 +362,7 @@ subroutine ISOMIP_initialize_temperature_salinity ( T, S, h, G, GV, US, param_fi ! call MOM_mesg(mesg,5) enddo - call calculate_density_derivs(T0, S0, pres, drho_dT, drho_dS, 1, 1, eqn_of_state, US) + call calculate_density_derivs(T0, S0, pres, drho_dT, drho_dS, eqn_of_state, US, dom=(/1,1/)) ! write(mesg,*) 'computed drho_dS, drho_dT', drho_dS(1), drho_dT(1) ! call MOM_mesg(mesg,5) call calculate_density(T0(1), S0(1), pres(1), rho_guess(1), eqn_of_state, US=US) @@ -374,8 +374,8 @@ subroutine ISOMIP_initialize_temperature_salinity ( T, S, h, G, GV, US, param_fi enddo ! Refine the guesses for each layer. do itt=1,6 - call calculate_density(T0, S0, pres, rho_guess, 1, nz, eqn_of_state, US=US) - call calculate_density_derivs(T0, S0, pres, drho_dT, drho_dS, 1, nz, eqn_of_state, US) + call calculate_density(T0, S0, pres, rho_guess, eqn_of_state, US=US) + call calculate_density_derivs(T0, S0, pres, drho_dT, drho_dS, eqn_of_state, US) do k=1,nz S0(k) = max(0.0, S0(k) + (GV%Rlay(k) - rho_guess(k)) / drho_dS1) enddo @@ -388,8 +388,8 @@ subroutine ISOMIP_initialize_temperature_salinity ( T, S, h, G, GV, US, param_fi enddo do itt=1,6 - call calculate_density(T0, S0, pres, rho_guess, 1, nz, eqn_of_state, US=US) - call calculate_density_derivs(T0, S0, pres, drho_dT, drho_dS, 1, nz, eqn_of_state, US) + call calculate_density(T0, S0, pres, rho_guess, eqn_of_state, US=US) + call calculate_density_derivs(T0, S0, pres, drho_dT, drho_dS, eqn_of_state, US) do k=1,nz T0(k) = T0(k) + (GV%Rlay(k) - rho_guess(k)) / drho_dT(k) enddo @@ -521,10 +521,10 @@ subroutine ISOMIP_initialize_sponges(G, GV, US, tv, PF, use_ALE, CSp, ACSp) enddo ; enddo ! Compute min/max density using T_SUR/S_SUR and T_BOT/S_BOT - call calculate_density(t_sur, s_sur, 0.0, rho_sur, tv%eqn_of_state, scale=US%kg_m3_to_R) + call calculate_density(t_sur, s_sur, 0.0, rho_sur, tv%eqn_of_state, US) !write (mesg,*) 'Surface density in sponge:', rho_sur ! call MOM_mesg(mesg,5) - call calculate_density(t_bot, s_bot, 0.0, rho_bot, tv%eqn_of_state, scale=US%kg_m3_to_R) + call calculate_density(t_bot, s_bot, 0.0, rho_bot, tv%eqn_of_state, US) !write (mesg,*) 'Bottom density in sponge:', rho_bot ! call MOM_mesg(mesg,5) rho_range = rho_bot - rho_sur diff --git a/src/user/benchmark_initialization.F90 b/src/user/benchmark_initialization.F90 index ff76654b28..ef3920f1bf 100644 --- a/src/user/benchmark_initialization.F90 +++ b/src/user/benchmark_initialization.F90 @@ -162,8 +162,8 @@ subroutine benchmark_initialize_thickness(h, G, GV, US, param_file, eqn_of_state ! Refine the guesses for each layer. do itt=1,6 - call calculate_density(T0, S0, pres, rho_guess, 1, nz, eqn_of_state, US=US) - call calculate_density_derivs(T0, S0, pres, drho_dT, drho_dS, 1, nz, eqn_of_state, US=US) + call calculate_density(T0, S0, pres, rho_guess, eqn_of_state, US=US) + call calculate_density_derivs(T0, S0, pres, drho_dT, drho_dS, eqn_of_state, US=US) do k=1,nz T0(k) = T0(k) + (GV%Rlay(k) - rho_guess(k)) / drho_dT(k) enddo @@ -258,7 +258,7 @@ subroutine benchmark_init_temperature_salinity(T, S, G, GV, US, param_file, & T0(k1) = 29.0 call calculate_density(T0(k1), S0(k1), pres(k1), rho_guess(k1), eqn_of_state, US=US) - call calculate_density_derivs(T0, S0, pres, drho_dT, drho_dS, k1, 1, eqn_of_state, US=US) + call calculate_density_derivs(T0, S0, pres, drho_dT, drho_dS, eqn_of_state, US=US, dom=(/k1,k1/)) ! A first guess of the layers' temperatures. ! do k=1,nz From 9c5239eafd8000ddb4eb865c37ecfd983064bd99 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sun, 19 Apr 2020 07:40:50 -0400 Subject: [PATCH 214/316] Corrected MOM_EOS dimensional rescaling problem Corrected problems with dimensional consistency testing in MOM_EOS.F90 that had been introduced with a recent merge. All answers are bitwise identical and are once again passing dimesional consistency testing. --- src/equation_of_state/MOM_EOS.F90 | 118 +++++++++--------------------- 1 file changed, 33 insertions(+), 85 deletions(-) diff --git a/src/equation_of_state/MOM_EOS.F90 b/src/equation_of_state/MOM_EOS.F90 index 034912b9ff..c7e8a37fd3 100644 --- a/src/equation_of_state/MOM_EOS.F90 +++ b/src/equation_of_state/MOM_EOS.F90 @@ -207,17 +207,11 @@ subroutine calculate_density_array(T, S, pressure, rho, start, npts, EOS, rho_re real, optional, intent(in) :: scale !< A multiplicative factor by which to scale density !! in combination with scaling given by US [various] - real :: p_scale ! A factor to convert pressure to units of Pa [Pa T2 R-1 L-2 ~> 1] - real :: rho_scale ! A factor to convert density from kg m-3 to the desired units [R m3 kg-1 ~> 1] - real, dimension(size(pressure)) :: pres ! Pressure converted to [Pa] integer :: j if (.not.associated(EOS)) call MOM_error(FATAL, & "calculate_density_array called with an unassociated EOS_type EOS.") - p_scale = EOS%RL2_T2_to_Pa - - if (p_scale == 1.0) then select case (EOS%form_of_EOS) case (EOS_LINEAR) call calculate_density_linear(T, S, pressure, rho, start, npts, & @@ -233,30 +227,10 @@ subroutine calculate_density_array(T, S, pressure, rho, start, npts, EOS, rho_re case default call MOM_error(FATAL, "calculate_density_array: EOS%form_of_EOS is not valid.") end select - else - do j=start,start+npts-1 ; pres(j) = p_scale * pressure(j) ; enddo - select case (EOS%form_of_EOS) - case (EOS_LINEAR) - call calculate_density_linear(T, S, pres, rho, start, npts, & - EOS%Rho_T0_S0, EOS%dRho_dT, EOS%dRho_dS, rho_ref) - case (EOS_UNESCO) - call calculate_density_unesco(T, S, pres, rho, start, npts, rho_ref) - case (EOS_WRIGHT) - call calculate_density_wright(T, S, pres, rho, start, npts, rho_ref) - case (EOS_TEOS10) - call calculate_density_teos10(T, S, pres, rho, start, npts, rho_ref) - case (EOS_NEMO) - call calculate_density_nemo(T, S, pres, rho, start, npts, rho_ref) - case default - call MOM_error(FATAL, "calculate_density_array: EOS%form_of_EOS is not valid.") - end select - endif - rho_scale = EOS%kg_m3_to_R - if (present(scale)) rho_scale = rho_scale * scale - if (rho_scale /= 1.0) then - do j=start,start+npts-1 ; rho(j) = rho_scale * rho(j) ; enddo - endif + if (present(scale)) then ; if (scale /= 1.0) then ; do j=start,start+npts-1 + rho(j) = scale * rho(j) + enddo ; endif ; endif end subroutine calculate_density_array @@ -547,61 +521,35 @@ subroutine calculate_density_derivs_array(T, S, pressure, drho_dT, drho_dS, star 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 - real, optional, intent(in) :: scale !< A multiplicative factor by which to scale density + real, optional, intent(in) :: scale !< A multiplicative factor by which to scale density !! in combination with scaling given by US [various] ! Local variables - real, dimension(size(pressure)) :: pres ! Pressure converted to [Pa] - real :: rho_scale ! A factor to convert density from kg m-3 to the desired units [R m3 kg-1 ~> 1] - real :: p_scale ! A factor to convert pressure to units of Pa [Pa T2 R-1 L-2 ~> 1] integer :: j if (.not.associated(EOS)) call MOM_error(FATAL, & "calculate_density_derivs called with an unassociated EOS_type EOS.") - p_scale = EOS%RL2_T2_to_Pa - - if (p_scale == 1.0) then - 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) - case (EOS_UNESCO) - call calculate_density_derivs_unesco(T, S, pressure, drho_dT, drho_dS, start, npts) - case (EOS_WRIGHT) - call calculate_density_derivs_wright(T, S, pressure, drho_dT, drho_dS, start, npts) - case (EOS_TEOS10) - call calculate_density_derivs_teos10(T, S, pressure, drho_dT, drho_dS, start, npts) - case (EOS_NEMO) - call calculate_density_derivs_nemo(T, S, pressure, drho_dT, drho_dS, start, npts) - case default - call MOM_error(FATAL, "calculate_density_derivs_array: EOS%form_of_EOS is not valid.") - end select - else - do j=start,start+npts-1 ; pres(j) = p_scale * pressure(j) ; enddo - select case (EOS%form_of_EOS) - case (EOS_LINEAR) - call calculate_density_derivs_linear(T, S, pres, 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, pres, drho_dT, drho_dS, start, npts) - case (EOS_WRIGHT) - call calculate_density_derivs_wright(T, S, pres, drho_dT, drho_dS, start, npts) - case (EOS_TEOS10) - call calculate_density_derivs_teos10(T, S, pres, drho_dT, drho_dS, start, npts) - case (EOS_NEMO) - call calculate_density_derivs_nemo(T, S, pres, drho_dT, drho_dS, start, npts) - case default - call MOM_error(FATAL, "calculate_density_derivs_array: EOS%form_of_EOS is not valid.") - end select - endif + 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) + case (EOS_UNESCO) + call calculate_density_derivs_unesco(T, S, pressure, drho_dT, drho_dS, start, npts) + case (EOS_WRIGHT) + call calculate_density_derivs_wright(T, S, pressure, drho_dT, drho_dS, start, npts) + case (EOS_TEOS10) + call calculate_density_derivs_teos10(T, S, pressure, drho_dT, drho_dS, start, npts) + case (EOS_NEMO) + call calculate_density_derivs_nemo(T, S, pressure, drho_dT, drho_dS, start, npts) + case default + call MOM_error(FATAL, "calculate_density_derivs_array: EOS%form_of_EOS is not valid.") + end select - rho_scale = EOS%kg_m3_to_R - if (present(scale)) rho_scale = rho_scale * scale - if (rho_scale /= 1.0) then ; do j=start,start+npts-1 - drho_dT(j) = rho_scale * drho_dT(j) - drho_dS(j) = rho_scale * drho_dS(j) - enddo ; endif + if (present(scale)) then ; if (scale /= 1.0) then ; do j=start,start+npts-1 + drho_dT(j) = scale * drho_dT(j) + drho_dS(j) = scale * drho_dS(j) + enddo ; endif ; endif end subroutine calculate_density_derivs_array @@ -665,8 +613,8 @@ subroutine calculate_density_derivs_scalar(T, S, pressure, drho_dT, drho_dS, EOS real, intent(out) :: drho_dS !< The partial derivative of density with salinity, !! in [kg m-3 ppt-1] or [R ppt-1 ~> kg m-3 ppt-1] type(EOS_type), pointer :: EOS !< Equation of state structure - real, optional, intent(in) :: scale !< A multiplicative factor by which to scale density - !! in combination with scaling given by US [various] + real, optional, intent(in) :: scale !< A multiplicative factor by which to scale density + !! in combination with scaling given by US [various] ! Local variables real :: rho_scale ! A factor to convert density from kg m-3 to the desired units [R m3 kg-1 ~> 1] real :: p_scale ! A factor to convert pressure to units of Pa [Pa T2 R-1 L-2 ~> 1] @@ -799,8 +747,8 @@ subroutine calculate_density_second_derivs_scalar(T, S, pressure, drho_dS_dS, dr real, intent(out) :: drho_dT_dP !< Partial derivative of alpha with respect to pressure !! [kg m-3 degC-1 Pa-1] or [R degC-1 Pa-1 ~> kg m-3 degC-1 Pa-1] type(EOS_type), pointer :: EOS !< Equation of state structure - real, optional, intent(in) :: scale !< A multiplicative factor by which to scale density - !! in combination with scaling given by US [various] + real, optional, intent(in) :: scale !< A multiplicative factor by which to scale density + !! in combination with scaling given by US [various] ! Local variables real :: rho_scale ! A factor to convert density from kg m-3 to the desired units [R m3 kg-1 ~> 1] real :: p_scale ! A factor to convert pressure to units of Pa [Pa T2 R-1 L-2 ~> 1] @@ -984,7 +932,7 @@ subroutine calculate_compress_array(T, S, press, rho, drho_dp, start, npts, EOS) end select if (EOS%kg_m3_to_R /= 1.0) then ; do i=is,ie - rho(i) = EOS%kg_m3_to_R * rho(i) + rho(i) = EOS%kg_m3_to_R * rho(i) enddo ; endif if (EOS%L_T_to_m_s /= 1.0) then ; do i=is,ie drho_dp(i) = EOS%L_T_to_m_s**2 * drho_dp(i) @@ -1004,6 +952,7 @@ subroutine calculate_compress_scalar(T, S, pressure, rho, drho_dp, EOS) !! inverse of the square of sound speed) [s2 m-2] or [T2 L-2] type(EOS_type), pointer :: EOS !< Equation of state structure + ! Local variables real, dimension(1) :: Ta, Sa, pa, rhoa, drho_dpa if (.not.associated(EOS)) call MOM_error(FATAL, & @@ -1947,7 +1896,7 @@ subroutine find_depth_of_pressure_in_cell(T_t, T_b, S_t, S_b, z_t, z_b, P_t, P_t GxRho = G_e * rho_ref ! Anomalous pressure difference across whole cell - dp = frac_dp_at_pos(T_t, T_b, S_t, S_b, z_t, z_b, rho_ref, G_e, 1.0, EOS, US) + dp = frac_dp_at_pos(T_t, T_b, S_t, S_b, z_t, z_b, rho_ref, G_e, 1.0, EOS) P_b = P_t + dp ! Anomalous pressure at bottom of cell @@ -1973,7 +1922,7 @@ subroutine find_depth_of_pressure_in_cell(T_t, T_b, S_t, S_b, z_t, z_b, P_t, P_t do while ( abs(Pa) > Pa_tol ) z_out = z_t + ( z_b - z_t ) * F_guess - Pa = frac_dp_at_pos(T_t, T_b, S_t, S_b, z_t, z_b, rho_ref, G_e, F_guess, EOS, US) - ( P_tgt - P_t ) + Pa = frac_dp_at_pos(T_t, T_b, S_t, S_b, z_t, z_b, rho_ref, G_e, F_guess, EOS) - ( P_tgt - P_t ) if (Pa 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, US) +real function frac_dp_at_pos(T_t, T_b, S_t, S_b, z_t, z_b, rho_ref, G_e, pos, EOS) real, intent(in) :: T_t !< Potential temperatue at the cell top [degC] real, intent(in) :: T_b !< Potential temperatue at the cell bottom [degC] real, intent(in) :: S_t !< Salinity at the cell top [ppt] @@ -2010,7 +1959,6 @@ real function frac_dp_at_pos(T_t, T_b, S_t, S_b, z_t, z_b, rho_ref, G_e, pos, EO real, intent(in) :: G_e !< The Earth's gravitational acceleration [L2 Z-1 T-2 ~> m s-2] real, intent(in) :: pos !< The fractional vertical position, 0 to 1 [nondim] type(EOS_type), pointer :: EOS !< Equation of state structure - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real :: fract_dp_at_pos !< The change in pressure from the layer top to !! fractional position pos [R L2 T-2 ~> Pa] ! Local variables @@ -2033,7 +1981,7 @@ real function frac_dp_at_pos(T_t, T_b, S_t, S_b, z_t, z_b, rho_ref, G_e, pos, EO T5(n) = top_weight * T_t + bottom_weight * T_b p5(n) = ( top_weight * z_t + bottom_weight * z_b ) * ( G_e * rho_ref ) enddo - call calculate_density_array(T5, S5, p5, rho5, 1, 5, EOS) + call calculate_density_1d(T5, S5, p5, rho5, EOS) rho5(:) = rho5(:) !- rho_ref ! Work with anomalies relative to rho_ref ! Use Bode's rule to estimate the average density From 718c3ab1f57d9bb4431434cf45b3c58b1771b8ac Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sun, 19 Apr 2020 18:26:14 -0400 Subject: [PATCH 215/316] Removed US argument to find_depth_of_pressure_in_cell Eliminated the US argument to find_depth_of_pressure_in_cell, which was no longer being used. Also stored EOS_domain values in MOM_state_initialization for reduced overhead. All answers are bitwise identical. --- src/equation_of_state/MOM_EOS.F90 | 5 ++--- .../MOM_state_initialization.F90 | 22 +++++++++++-------- 2 files changed, 15 insertions(+), 12 deletions(-) diff --git a/src/equation_of_state/MOM_EOS.F90 b/src/equation_of_state/MOM_EOS.F90 index c7e8a37fd3..49820d7ff8 100644 --- a/src/equation_of_state/MOM_EOS.F90 +++ b/src/equation_of_state/MOM_EOS.F90 @@ -1159,7 +1159,7 @@ end function query_compressible subroutine EOS_init(param_file, EOS, US) type(param_file_type), intent(in) :: param_file !< Parameter file structure type(EOS_type), pointer :: EOS !< Equation of state structure - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type optional :: US ! Local variables #include "version_variable.h" @@ -1869,7 +1869,7 @@ end subroutine int_density_dz_generic_plm !> Find the depth at which the reconstructed pressure matches P_tgt subroutine find_depth_of_pressure_in_cell(T_t, T_b, S_t, S_b, z_t, z_b, P_t, P_tgt, & - rho_ref, G_e, EOS, US, P_b, z_out, z_tol) + rho_ref, G_e, EOS, P_b, z_out, z_tol) real, intent(in) :: T_t !< Potential temperatue at the cell top [degC] real, intent(in) :: T_b !< Potential temperatue at the cell bottom [degC] real, intent(in) :: S_t !< Salinity at the cell top [ppt] @@ -1881,7 +1881,6 @@ subroutine find_depth_of_pressure_in_cell(T_t, T_b, S_t, S_b, z_t, z_b, P_t, P_t real, intent(in) :: rho_ref !< Reference density with which calculation are anomalous to [R ~> kg m-3] real, intent(in) :: G_e !< Gravitational acceleration [L2 Z-1 T-2 ~> m s-2] type(EOS_type), pointer :: EOS !< Equation of state structure - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real, intent(out) :: P_b !< Pressure at the bottom of the cell [R L2 T-2 ~> Pa] real, intent(out) :: z_out !< Absolute depth at which anomalous pressure = p_tgt [Z ~> m] real, optional, intent(in) :: z_tol !< The tolerance in finding z_out [Z ~> m] diff --git a/src/initialization/MOM_state_initialization.F90 b/src/initialization/MOM_state_initialization.F90 index 7b58ca6933..aa22f3cea0 100644 --- a/src/initialization/MOM_state_initialization.F90 +++ b/src/initialization/MOM_state_initialization.F90 @@ -939,6 +939,7 @@ subroutine convert_thickness(h, G, GV, US, tv) ! [H T2 R-1 L-2 ~> s2 m2 kg-1 or s2 m-1] real :: HR_to_pres ! A conversion factor from the input geometric thicknesses times the layer ! densities into pressure units [L2 T-2 H-1 ~> m s-2 or m4 kg-1 s-2]. + integer, dimension(2) :: EOSdom ! The i-computational domain for the equation of state integer :: i, j, k, is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz integer :: itt, max_itt @@ -956,11 +957,12 @@ subroutine convert_thickness(h, G, GV, US, tv) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 p_bot(i,j) = 0.0 ; p_top(i,j) = 0.0 enddo ; enddo + EOSdom(:) = EOS_domain(G%HI) do k=1,nz do j=js,je do i=is,ie ; p_top(i,j) = p_bot(i,j) ; enddo call calculate_density(tv%T(:,j,k), tv%S(:,j,k), p_top(:,j), rho, & - tv%eqn_of_state, dom=EOS_domain(G%HI)) + tv%eqn_of_state, EOSdom) do i=is,ie p_bot(i,j) = p_top(i,j) + HR_to_pres * (h(i,j,k) * rho(i)) enddo @@ -971,7 +973,7 @@ subroutine convert_thickness(h, G, GV, US, tv) tv%eqn_of_state, dz_geo) if (itt < max_itt) then ; do j=js,je call calculate_density(tv%T(:,j,k), tv%S(:,j,k), p_bot(:,j), rho, & - tv%eqn_of_state, dom=EOS_domain(G%HI)) + tv%eqn_of_state, EOSdom) ! Use Newton's method to correct the bottom value. ! The hydrostatic equation is sufficiently linear that no bounds-checking is needed. do i=is,ie @@ -1215,7 +1217,7 @@ subroutine cut_off_column_top(nk, tv, GV, US, G_earth, depth, min_thickness, T, e_top = e(1) do k=1,nk call find_depth_of_pressure_in_cell(T_t(k), T_b(k), S_t(k), S_b(k), e(K), e(K+1), & - P_t, p_surf, GV%Rho0, G_earth, tv%eqn_of_state, US, & + P_t, p_surf, GV%Rho0, G_earth, tv%eqn_of_state, & P_b, z_out, z_tol=z_tol) if (z_out>=e(K)) then ! Imposed pressure was less that pressure at top of cell @@ -1601,7 +1603,7 @@ subroutine initialize_temp_salt_fit(T, S, G, GV, US, param_file, eqn_of_state, P enddo call calculate_density(T0(1), S0(1), pres(1), rho_guess(1), eqn_of_state) - call calculate_density_derivs(T0, S0, pres, drho_dT, drho_dS, eqn_of_state, dom=(/1,1/)) + call calculate_density_derivs(T0, S0, pres, drho_dT, drho_dS, eqn_of_state, (/1,1/) ) if (fit_salin) then ! A first guess of the layers' temperatures. @@ -1735,6 +1737,7 @@ subroutine initialize_sponges_file(G, GV, US, use_temperature, tv, param_file, C real :: Idamp(SZI_(G),SZJ_(G)) ! The inverse damping rate [T-1 ~> s-1]. real :: pres(SZI_(G)) ! An array of the reference pressure [R L2 T-2 ~> Pa]. + integer, dimension(2) :: EOSdom ! The i-computational domain for the equation of state integer :: i, j, k, is, ie, js, je, nz integer :: isd, ied, jsd, jed integer, dimension(4) :: siz @@ -1864,13 +1867,13 @@ subroutine initialize_sponges_file(G, GV, US, use_temperature, tv, param_file, C ! mixed layer density, which is used in determining which layers can be ! inflated without causing static instabilities. do i=is-1,ie ; pres(i) = tv%P_Ref ; enddo + EOSdom(:) = EOS_domain(G%HI) call MOM_read_data(filename, potemp_var, tmp(:,:,:), G%Domain) call MOM_read_data(filename, salin_var, tmp2(:,:,:), G%Domain) do j=js,je - call calculate_density(tmp(:,j,1), tmp2(:,j,1), pres, tmp_2d(:,j), tv%eqn_of_state, & - dom=EOS_domain(G%HI)) + call calculate_density(tmp(:,j,1), tmp2(:,j,1), pres, tmp_2d(:,j), tv%eqn_of_state, EOSdom) enddo call set_up_sponge_ML_density(tmp_2d, G, CSp) @@ -1977,6 +1980,7 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, G, GV, US, PF, just_read_param # include "version_variable.h" character(len=40) :: mdl = "MOM_initialize_layers_from_Z" ! This module's name. + integer, dimension(2) :: EOSdom ! The i-computational domain for the equation of state integer :: is, ie, js, je, nz ! compute domain indices integer :: isc,iec,jsc,jec ! global compute domain indices integer :: isg, ieg, jsg, jeg ! global extent @@ -2188,9 +2192,9 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, G, GV, US, PF, just_read_param call convert_temp_salt_for_TEOS10(temp_z, salt_z, G%HI, kd, mask_z, eos) press(:) = tv%P_Ref + EOSdom(:) = EOS_domain(G%HI) do k=1,kd ; do j=js,je - call calculate_density(temp_z(:,j,k), salt_z(:,j,k), press, rho_z(:,j,k), eos, & - dom=EOS_domain(G%HI)) + call calculate_density(temp_z(:,j,k), salt_z(:,j,k), press, rho_z(:,j,k), eos, EOSdom) enddo ; enddo call pass_var(temp_z,G%Domain) @@ -2458,7 +2462,7 @@ subroutine MOM_state_init_tests(G, GV, US, tv) P_t = 0. do k = 1, nk call find_depth_of_pressure_in_cell(T_t(k), T_b(k), S_t(k), S_b(k), e(K), e(K+1), P_t, 0.5*P_tot, & - GV%Rho0, GV%g_Earth, tv%eqn_of_state, US, P_b, z_out) + GV%Rho0, GV%g_Earth, tv%eqn_of_state, P_b, z_out) write(0,*) k, US%RL2_T2_to_Pa*P_t, US%RL2_T2_to_Pa*P_b, 0.5*US%RL2_T2_to_Pa*P_tot, & US%Z_to_m*e(K), US%Z_to_m*e(K+1), US%Z_to_m*z_out P_t = P_b From e3c434e575f869ae703ae54eefe4f668eae90c7c Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sun, 19 Apr 2020 18:51:25 -0400 Subject: [PATCH 216/316] Store return values from EOS_domain Store the return values from EOS_domain for computational efficiency. Also cleaned up unneeded 'dom=' declarations in compute_density calls. All answers are bitwise identical. --- src/ALE/coord_adapt.F90 | 10 ++++---- src/ALE/coord_slight.F90 | 4 +-- src/core/MOM.F90 | 6 +++-- src/core/MOM_PressureForce_Montgomery.F90 | 18 ++++++------- src/core/MOM_PressureForce_analytic_FV.F90 | 14 +++++------ src/core/MOM_PressureForce_blocked_AFV.F90 | 10 ++++---- src/core/MOM_forcing_type.F90 | 2 +- src/core/MOM_isopycnal_slopes.F90 | 4 +-- src/diagnostics/MOM_diagnostics.F90 | 14 +++++++---- src/diagnostics/MOM_wave_speed.F90 | 4 +-- src/diagnostics/MOM_wave_structure.F90 | 2 +- src/ice_shelf/MOM_ice_shelf.F90 | 6 +++-- .../MOM_coord_initialization.F90 | 4 +-- .../lateral/MOM_mixed_layer_restrat.F90 | 23 +++++++++-------- .../lateral/MOM_thickness_diffuse.F90 | 8 +++--- .../vertical/MOM_bulk_mixed_layer.F90 | 14 +++++------ .../vertical/MOM_diabatic_aux.F90 | 25 ++++++++++--------- .../vertical/MOM_diabatic_driver.F90 | 4 ++- .../vertical/MOM_entrain_diffusive.F90 | 15 +++++------ .../vertical/MOM_full_convection.F90 | 10 ++++---- .../vertical/MOM_geothermal.F90 | 4 +-- .../vertical/MOM_internal_tide_input.F90 | 6 +++-- .../vertical/MOM_kappa_shear.F90 | 2 +- .../vertical/MOM_regularize_layers.F90 | 10 ++++---- .../vertical/MOM_set_diffusivity.F90 | 21 ++++++++++------ .../vertical/MOM_set_viscosity.F90 | 12 ++++----- src/tracer/MOM_neutral_diffusion.F90 | 8 +++--- src/tracer/MOM_tracer_Z_init.F90 | 8 +++--- src/tracer/MOM_tracer_hor_diff.F90 | 4 ++- src/user/DOME_initialization.F90 | 2 +- src/user/ISOMIP_initialization.F90 | 2 +- src/user/RGC_initialization.F90 | 6 ++--- src/user/benchmark_initialization.F90 | 2 +- src/user/user_change_diffusivity.F90 | 8 +++--- 34 files changed, 157 insertions(+), 135 deletions(-) diff --git a/src/ALE/coord_adapt.F90 b/src/ALE/coord_adapt.F90 index 58e2aaa131..42ae0ee245 100644 --- a/src/ALE/coord_adapt.F90 +++ b/src/ALE/coord_adapt.F90 @@ -159,7 +159,7 @@ subroutine build_adapt_column(CS, G, GV, US, tv, i, j, zInt, tInt, sInt, h, zNex 0.5 * (tInt(i,j,2:nz) + tInt(i,j-1,2:nz)), & 0.5 * (sInt(i,j,2:nz) + sInt(i,j-1,2:nz)), & 0.5 * (zInt(i,j,2:nz) + zInt(i,j-1,2:nz)) * (GV%H_to_RZ * GV%g_Earth), & - alpha, beta, tv%eqn_of_state, (/2,nz/)) + alpha, beta, tv%eqn_of_state, (/2,nz/) ) del2sigma(2:nz) = del2sigma(2:nz) + & (alpha(2:nz) * (tInt(i,j-1,2:nz) - tInt(i,j,2:nz)) + & @@ -171,7 +171,7 @@ subroutine build_adapt_column(CS, G, GV, US, tv, i, j, zInt, tInt, sInt, h, zNex 0.5 * (tInt(i,j,2:nz) + tInt(i,j+1,2:nz)), & 0.5 * (sInt(i,j,2:nz) + sInt(i,j+1,2:nz)), & 0.5 * (zInt(i,j,2:nz) + zInt(i,j+1,2:nz)) * (GV%H_to_RZ * GV%g_Earth), & - alpha, beta, tv%eqn_of_state, (/2,nz/)) + alpha, beta, tv%eqn_of_state, (/2,nz/) ) del2sigma(2:nz) = del2sigma(2:nz) + & (alpha(2:nz) * (tInt(i,j+1,2:nz) - tInt(i,j,2:nz)) + & @@ -183,7 +183,7 @@ subroutine build_adapt_column(CS, G, GV, US, tv, i, j, zInt, tInt, sInt, h, zNex 0.5 * (tInt(i,j,2:nz) + tInt(i-1,j,2:nz)), & 0.5 * (sInt(i,j,2:nz) + sInt(i-1,j,2:nz)), & 0.5 * (zInt(i,j,2:nz) + zInt(i-1,j,2:nz)) * (GV%H_to_RZ * GV%g_Earth), & - alpha, beta, tv%eqn_of_state, (/2,nz/)) + alpha, beta, tv%eqn_of_state, (/2,nz/) ) del2sigma(2:nz) = del2sigma(2:nz) + & (alpha(2:nz) * (tInt(i-1,j,2:nz) - tInt(i,j,2:nz)) + & @@ -195,7 +195,7 @@ subroutine build_adapt_column(CS, G, GV, US, tv, i, j, zInt, tInt, sInt, h, zNex 0.5 * (tInt(i,j,2:nz) + tInt(i+1,j,2:nz)), & 0.5 * (sInt(i,j,2:nz) + sInt(i+1,j,2:nz)), & 0.5 * (zInt(i,j,2:nz) + zInt(i+1,j,2:nz)) * (GV%H_to_RZ * GV%g_Earth), & - alpha, beta, tv%eqn_of_state, (/2,nz/)) + alpha, beta, tv%eqn_of_state, (/2,nz/) ) del2sigma(2:nz) = del2sigma(2:nz) + & (alpha(2:nz) * (tInt(i+1,j,2:nz) - tInt(i,j,2:nz)) + & @@ -209,7 +209,7 @@ subroutine build_adapt_column(CS, G, GV, US, tv, i, j, zInt, tInt, sInt, h, zNex ! a positive curvature means we're too light relative to adjacent columns, ! so del2sigma needs to be positive too (push the interface deeper) call calculate_density_derivs(tInt(i,j,:), sInt(i,j,:), zInt(i,j,:) * (GV%H_to_RZ * GV%g_Earth), & - alpha, beta, tv%eqn_of_state, (/1,nz/)) !### This should be (/1,nz+1/) - see 25 lines below. + alpha, beta, tv%eqn_of_state, (/1,nz/) ) !### This should be (/1,nz+1/) - see 25 lines below. do K = 2, nz ! TODO make lower bound here configurable dh_d2s(K) = del2sigma(K) * (0.5 * (h(i,j,k-1) + h(i,j,k))) / & diff --git a/src/ALE/coord_slight.F90 b/src/ALE/coord_slight.F90 index 1f6bff8103..5cfa09213f 100644 --- a/src/ALE/coord_slight.F90 +++ b/src/ALE/coord_slight.F90 @@ -373,9 +373,9 @@ subroutine build_slight_column(CS, eqn_of_state, H_to_pres, H_subroundoff, & T_int(nz+1) = T_f(nz) ; S_int(nz+1) = S_f(nz) p_IS(nz+1) = z_col(nz+1) * H_to_pres call calculate_density_derivs(T_int, S_int, p_IS, drhoIS_dT, drhoIS_dS, & - eqn_of_state, dom=(/2,nz/)) + eqn_of_state, (/2,nz/) ) call calculate_density_derivs(T_int, S_int, p_R, drhoR_dT, drhoR_dS, & - eqn_of_state, dom=(/2,nz/)) + eqn_of_state, (/2,nz/) ) if (CS%compressibility_fraction > 0.0) then call calculate_compress(T_int, S_int, p_R(:), rho_tmp, drho_dp, 2, nz-1, eqn_of_state) else diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index 1d7ed5b1d6..5c7f79fe32 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -2895,9 +2895,11 @@ subroutine adjust_ssh_for_p_atm(tv, G, GV, US, ssh, p_atm, use_EOS) ! a corrected effective SSH [R ~> kg m-3]. real :: IgR0 ! The SSH conversion factor from R L2 T-2 to m [m T2 R-1 L-2 ~> m Pa-1]. logical :: calc_rho + integer, dimension(2) :: EOSdom ! The i-computational domain for the equation of state integer :: i, j, is, ie, js, je - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + EOSdom(:) = EOS_domain(G%HI) 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 @@ -2905,7 +2907,7 @@ subroutine adjust_ssh_for_p_atm(tv, G, GV, US, ssh, p_atm, use_EOS) do j=js,je if (calc_rho) then call calculate_density(tv%T(:,j,1), tv%S(:,j,1), 0.5*p_atm(:,j), Rho_conv, & - tv%eqn_of_state, dom=EOS_domain(G%HI)) + tv%eqn_of_state, EOSdom) do i=is,ie IgR0 = US%Z_to_m / (Rho_conv(i) * GV%g_Earth) ssh(i,j) = ssh(i,j) + p_atm(i,j) * IgR0 diff --git a/src/core/MOM_PressureForce_Montgomery.F90 b/src/core/MOM_PressureForce_Montgomery.F90 index a338bc2899..99268460df 100644 --- a/src/core/MOM_PressureForce_Montgomery.F90 +++ b/src/core/MOM_PressureForce_Montgomery.F90 @@ -230,7 +230,7 @@ subroutine PressureForce_Mont_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, pb 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(:), & - tv%eqn_of_state, dom=EOSdom) + tv%eqn_of_state, EOSdom) 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) @@ -247,7 +247,7 @@ subroutine PressureForce_Mont_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, pb !$OMP parallel do default(shared) private(rho_in_situ) do k=1,nz ; do j=Jsq,Jeq+1 call calculate_density(tv_tmp%T(:,j,k), tv_tmp%S(:,j,k), p_ref, rho_in_situ, & - tv%eqn_of_state, dom=EOSdom) + tv%eqn_of_state, EOSdom) do i=Isq,Ieq+1 ; alpha_star(i,j,k) = 1.0 / rho_in_situ(i) ; enddo enddo ; enddo endif ! use_EOS @@ -487,7 +487,7 @@ subroutine PressureForce_Mont_Bouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, pbce, 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(:), & - tv%eqn_of_state, dom=EOSdom) + tv%eqn_of_state, EOSdom) do k=nkmb+1,nz ; do i=Isq,Ieq+1 if (GV%Rlay(k) < Rho_cv_BL(i)) then @@ -508,7 +508,7 @@ subroutine PressureForce_Mont_Bouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, pbce, !$OMP parallel do default(shared) do k=1,nz+1 ; do j=Jsq,Jeq+1 call calculate_density(tv_tmp%T(:,j,k), tv_tmp%S(:,j,k), p_ref, rho_star(:,j,k), & - tv%eqn_of_state, dom=EOSdom) + tv%eqn_of_state, EOSdom) do i=Isq,Ieq+1 ; rho_star(i,j,k) = G_Rho0*rho_star(i,j,k) ; enddo enddo ; enddo endif ! use_EOS @@ -666,7 +666,7 @@ subroutine Set_pbce_Bouss(e, tv, G, GV, US, Rho0, GFS_scale, pbce, rho_star) press(i) = -Rho0xG*e(i,j,1) enddo call calculate_density(tv%T(:,j,1), tv%S(:,j,1), press, rho_in_situ, & - tv%eqn_of_state, dom=EOSdom) + tv%eqn_of_state, EOSdom) do i=Isq,Ieq+1 pbce(i,j,1) = G_Rho0*(GFS_scale * rho_in_situ(i)) * GV%H_to_Z enddo @@ -677,7 +677,7 @@ subroutine Set_pbce_Bouss(e, tv, G, GV, US, Rho0, GFS_scale, pbce, rho_star) S_int(i) = 0.5*(tv%S(i,j,k-1)+tv%S(i,j,k)) enddo call calculate_density_derivs(T_int, S_int, press, dR_dT, dR_dS, & - tv%eqn_of_state, dom=EOSdom) + tv%eqn_of_state, EOSdom) do i=Isq,Ieq+1 pbce(i,j,k) = pbce(i,j,k-1) + G_Rho0 * & ((e(i,j,K) - e(i,j,nz+1)) * Ihtot(i)) * & @@ -764,7 +764,7 @@ subroutine Set_pbce_nonBouss(p, tv, G, GV, US, GFS_scale, pbce, alpha_star) !$OMP parallel do default(shared) private(T_int,S_int,dR_dT,dR_dS,rho_in_situ) do j=Jsq,Jeq+1 call calculate_density(tv%T(:,j,nz), tv%S(:,j,nz), p(:,j,nz+1), rho_in_situ, & - tv%eqn_of_state, dom=EOSdom) + tv%eqn_of_state, EOSdom) do i=Isq,Ieq+1 C_htot(i,j) = dP_dH / ((p(i,j,nz+1)-p(i,j,1)) + dp_neglect) pbce(i,j,nz) = dP_dH / (rho_in_situ(i)) @@ -774,9 +774,9 @@ subroutine Set_pbce_nonBouss(p, tv, G, GV, US, GFS_scale, pbce, alpha_star) T_int(i) = 0.5*(tv%T(i,j,k)+tv%T(i,j,k+1)) S_int(i) = 0.5*(tv%S(i,j,k)+tv%S(i,j,k+1)) enddo - call calculate_density(T_int, S_int, p(:,j,k+1), rho_in_situ, tv%eqn_of_state, dom=EOSdom) + call calculate_density(T_int, S_int, p(:,j,k+1), rho_in_situ, tv%eqn_of_state, EOSdom) call calculate_density_derivs(T_int, S_int, p(:,j,k+1), dR_dT, dR_dS, & - tv%eqn_of_state, dom=EOSdom) + tv%eqn_of_state, EOSdom) do i=Isq,Ieq+1 pbce(i,j,k) = pbce(i,j,k+1) + ((p(i,j,K+1)-p(i,j,1))*C_htot(i,j)) * & ((dR_dT(i)*(tv%T(i,j,k+1)-tv%T(i,j,k)) + & diff --git a/src/core/MOM_PressureForce_analytic_FV.F90 b/src/core/MOM_PressureForce_analytic_FV.F90 index 0f9dff1373..614bf3bc8a 100644 --- a/src/core/MOM_PressureForce_analytic_FV.F90 +++ b/src/core/MOM_PressureForce_analytic_FV.F90 @@ -177,7 +177,7 @@ subroutine PressureForce_AFV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p ! real :: oneatm = 101325.0 ! 1 atm in [Pa] = [kg m-1 s-2] real, parameter :: C1_6 = 1.0/6.0 integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz, nkmb - integer, dimension(2) :: EOSdom + integer, dimension(2) :: EOSdom ! The i-computational domain for the equation of state integer :: i, j, k is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke @@ -230,7 +230,7 @@ subroutine PressureForce_AFV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p 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(:), & - tv%eqn_of_state, dom=EOSdom) + tv%eqn_of_state, EOSdom) 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) @@ -336,7 +336,7 @@ subroutine PressureForce_AFV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p !$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, & - tv%eqn_of_state, dom=EOSdom) + tv%eqn_of_state, EOSdom) 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)) @@ -505,7 +505,7 @@ subroutine PressureForce_AFV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_at type(thermo_var_ptrs) :: tv_tmp! A structure of temporary T & S. real, parameter :: C1_6 = 1.0/6.0 - integer, dimension(2) :: EOSdom ! The computational domain for the equation of state + integer, dimension(2) :: EOSdom ! The i-computational domain for the equation of state integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz, nkmb integer :: i, j, k @@ -581,7 +581,7 @@ subroutine PressureForce_AFV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_at 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(:), & - tv%eqn_of_state, dom=EOSdom) + tv%eqn_of_state, EOSdom) do k=nkmb+1,nz ; do i=Isq,Ieq+1 if (GV%Rlay(k) < Rho_cv_BL(i)) then @@ -604,10 +604,10 @@ subroutine PressureForce_AFV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_at 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, & - tv%eqn_of_state, dom=EOSdom) + tv%eqn_of_state, EOSdom) else call calculate_density(tv_tmp%T(:,j,1), tv_tmp%S(:,j,1), p0, rho_in_situ, & - tv%eqn_of_state, dom=EOSdom) + tv%eqn_of_state, EOSdom) endif do i=Isq,Ieq+1 dM(i,j) = (CS%GFS_scale - 1.0) * (G_Rho0 * rho_in_situ(i)) * e(i,j,1) diff --git a/src/core/MOM_PressureForce_blocked_AFV.F90 b/src/core/MOM_PressureForce_blocked_AFV.F90 index d647ffda46..ab0c665f7a 100644 --- a/src/core/MOM_PressureForce_blocked_AFV.F90 +++ b/src/core/MOM_PressureForce_blocked_AFV.F90 @@ -226,7 +226,7 @@ subroutine PressureForce_blk_AFV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, 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(:), & - tv%eqn_of_state, dom=EOSdom) + tv%eqn_of_state, EOSdom) 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) @@ -304,7 +304,7 @@ subroutine PressureForce_blk_AFV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, !$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, & - tv%eqn_of_state, dom=EOSdom) + tv%eqn_of_state, EOSdom) 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)) @@ -568,7 +568,7 @@ subroutine PressureForce_blk_AFV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, 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(:), & - tv%eqn_of_state, dom=EOSdom) + tv%eqn_of_state, EOSdom) do k=nkmb+1,nz ; do i=Isq,Ieq+1 if (GV%Rlay(k) < Rho_cv_BL(i)) then @@ -591,10 +591,10 @@ subroutine PressureForce_blk_AFV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, 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, & - tv%eqn_of_state, dom=EOSdom) + tv%eqn_of_state, EOSdom) else call calculate_density(tv_tmp%T(:,j,1), tv_tmp%S(:,j,1), p0, rho_in_situ, & - tv%eqn_of_state, dom=EOSdom) + tv%eqn_of_state, EOSdom) endif do i=Isq,Ieq+1 dM(i,j) = (CS%GFS_scale - 1.0) * (G_Rho0 * rho_in_situ(i)) * e(i,j,1) diff --git a/src/core/MOM_forcing_type.F90 b/src/core/MOM_forcing_type.F90 index 071a912325..73efeec927 100644 --- a/src/core/MOM_forcing_type.F90 +++ b/src/core/MOM_forcing_type.F90 @@ -954,7 +954,7 @@ subroutine calculateBuoyancyFlux1d(G, GV, US, fluxes, optics, nsw, h, Temp, Salt ! Density derivatives call calculate_density_derivs(Temp(:,j,1), Salt(:,j,1), pressure, dRhodT, dRhodS, & - tv%eqn_of_state, dom=EOS_domain(G%HI)) + tv%eqn_of_state, EOS_domain(G%HI)) ! Adjust netSalt to reflect dilution effect of FW flux netSalt(G%isc:G%iec) = netSalt(G%isc:G%iec) - Salt(G%isc:G%iec,j,1) * netH(G%isc:G%iec) ! ppt H/s diff --git a/src/core/MOM_isopycnal_slopes.F90 b/src/core/MOM_isopycnal_slopes.F90 index bb0bb52bfc..4f1a2d261e 100644 --- a/src/core/MOM_isopycnal_slopes.F90 +++ b/src/core/MOM_isopycnal_slopes.F90 @@ -179,7 +179,7 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, & S_u(I) = 0.25*((S(i,j,k) + S(i+1,j,k)) + (S(i,j,k-1) + S(i+1,j,k-1))) enddo call calculate_density_derivs(T_u, S_u, pres_u, drho_dT_u, drho_dS_u, & - tv%eqn_of_state, dom=EOSdom_u) + tv%eqn_of_state, EOSdom_u) endif do I=is-1,ie @@ -267,7 +267,7 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, & S_v(i) = 0.25*((S(i,j,k) + S(i,j+1,k)) + (S(i,j,k-1) + S(i,j+1,k-1))) enddo call calculate_density_derivs(T_v, S_v, pres_v, drho_dT_v, drho_dS_v, tv%eqn_of_state, & - dom=EOSdom_v) + EOSdom_v) endif do i=is,ie if (use_EOS) then diff --git a/src/diagnostics/MOM_diagnostics.F90 b/src/diagnostics/MOM_diagnostics.F90 index 8d2ea162f1..38529fb958 100644 --- a/src/diagnostics/MOM_diagnostics.F90 +++ b/src/diagnostics/MOM_diagnostics.F90 @@ -223,6 +223,7 @@ subroutine calculate_diagnostic_fields(u, v, h, uh, vh, tv, ADp, CDp, p_surf, & !! calculating interface heights [H ~> m or kg m-2]. ! Local variables + integer, dimension(2) :: EOSdom ! The i-computational domain for the equation of state integer i, j, k, is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz, nkmb real :: Rcv(SZI_(G),SZJ_(G),SZK_(G)) ! Coordinate variable potential density [R ~> kg m-3]. @@ -344,6 +345,7 @@ subroutine calculate_diagnostic_fields(u, v, h, uh, vh, tv, ADp, CDp, p_surf, & call post_data(CS%id_volcello, work_3d, CS%diag) endif else ! thkcello = dp/(rho*g) for non-Boussinesq + EOSdom(:) = EOS_domain(G%HI) do j=js,je if (associated(p_surf)) then ! Pressure loading at top of surface layer [R L2 T-2 ~> Pa] do i=is,ie @@ -360,7 +362,7 @@ subroutine calculate_diagnostic_fields(u, v, h, uh, vh, tv, ADp, CDp, p_surf, & enddo ! Store in-situ density [R ~> kg m-3] in work_3d call calculate_density(tv%T(:,j,k), tv%S(:,j,k), pressure_1d, rho_in_situ, & - tv%eqn_of_state, dom=EOS_domain(G%HI)) + tv%eqn_of_state, EOSdom) do i=is,ie ! Cell thickness = dz = dp/(g*rho) (meter); store in work_3d work_3d(i,j,k) = (GV%H_to_RZ*h(i,j,k)) / rho_in_situ(i) enddo @@ -462,11 +464,12 @@ subroutine calculate_diagnostic_fields(u, v, h, uh, vh, tv, ADp, CDp, p_surf, & associated(CS%uhGM_Rlay) .or. associated(CS%vhGM_Rlay)) then if (associated(tv%eqn_of_state)) then + EOSdom(:) = EOS_domain(G%HI) pressure_1d(:) = tv%P_Ref !$OMP parallel do default(shared) do k=1,nz ; do j=js-1,je+1 call calculate_density(tv%T(:,j,k), tv%S(:,j,k), pressure_1d, Rcv(:,j,k), tv%eqn_of_state, & - dom=EOS_domain(G%HI, halo=1)) + EOSdom) enddo ; enddo else ! Rcv should not be used much in this case, so fill in sensible values. do k=1,nz ; do j=js-1,je+1 ; do i=is-1,ie+1 @@ -584,12 +587,13 @@ subroutine calculate_diagnostic_fields(u, v, h, uh, vh, tv, ADp, CDp, p_surf, & endif if (associated(tv%eqn_of_state)) then + EOSdom(:) = EOS_domain(G%HI) if (CS%id_rhopot0 > 0) then pressure_1d(:) = 0. !$OMP parallel do default(shared) do k=1,nz ; do j=js,je call calculate_density(tv%T(:,j,k), tv%S(:,j,k), pressure_1d, Rcv(:,j,k), & - tv%eqn_of_state, dom=EOS_domain(G%HI)) + tv%eqn_of_state, EOSdom) enddo ; enddo if (CS%id_rhopot0 > 0) call post_data(CS%id_rhopot0, Rcv, CS%diag) endif @@ -598,7 +602,7 @@ subroutine calculate_diagnostic_fields(u, v, h, uh, vh, tv, ADp, CDp, p_surf, & !$OMP parallel do default(shared) do k=1,nz ; do j=js,je call calculate_density(tv%T(:,j,k), tv%S(:,j,k), pressure_1d, Rcv(:,j,k), & - tv%eqn_of_state, dom=EOS_domain(G%HI)) + tv%eqn_of_state, EOSdom) enddo ; enddo if (CS%id_rhopot2 > 0) call post_data(CS%id_rhopot2, Rcv, CS%diag) endif @@ -609,7 +613,7 @@ subroutine calculate_diagnostic_fields(u, v, h, uh, vh, tv, ADp, CDp, p_surf, & do k=1,nz pressure_1d(:) = pressure_1d(:) + 0.5 * h(:,j,k) * (GV%H_to_RZ*GV%g_Earth) ! Pressure in middle of layer k call calculate_density(tv%T(:,j,k), tv%S(:,j,k), pressure_1d, Rcv(:,j,k), & - tv%eqn_of_state, dom=EOS_domain(G%HI)) + tv%eqn_of_state, EOSdom) pressure_1d(:) = pressure_1d(:) + 0.5 * h(:,j,k) * (GV%H_to_RZ*GV%g_Earth) ! Pressure at bottom of layer k enddo enddo diff --git a/src/diagnostics/MOM_wave_speed.F90 b/src/diagnostics/MOM_wave_speed.F90 index ea918d218e..c955c4eb95 100644 --- a/src/diagnostics/MOM_wave_speed.F90 +++ b/src/diagnostics/MOM_wave_speed.F90 @@ -243,7 +243,7 @@ subroutine wave_speed(h, tv, G, GV, US, cg1, CS, full_halos, use_ebt_mode, & S_int(k) = 0.5*(Sf(k,i)+Sf(k-1,i)) enddo call calculate_density_derivs(T_int, S_int, pres, drho_dT, drho_dS, & - tv%eqn_of_state, dom=(/2,kf(i)/)) + tv%eqn_of_state, (/2,kf(i)/) ) ! Sum the reduced gravities to find out how small a density difference ! is negligibly small. @@ -738,7 +738,7 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, full_halos) S_int(k) = 0.5*(Sf(k,i)+Sf(k-1,i)) enddo call calculate_density_derivs(T_int, S_int, pres, drho_dT, drho_dS, & - tv%eqn_of_state, dom=(/2,kf(i)/)) + tv%eqn_of_state, (/2,kf(i)/) ) ! Sum the reduced gravities to find out how small a density difference ! is negligibly small. diff --git a/src/diagnostics/MOM_wave_structure.F90 b/src/diagnostics/MOM_wave_structure.F90 index db6d74035a..632a68e0ce 100644 --- a/src/diagnostics/MOM_wave_structure.F90 +++ b/src/diagnostics/MOM_wave_structure.F90 @@ -278,7 +278,7 @@ subroutine wave_structure(h, tv, G, GV, US, cn, ModeNum, freq, CS, En, full_halo S_int(k) = 0.5*(Sf(k,i)+Sf(k-1,i)) enddo call calculate_density_derivs(T_int, S_int, pres, drho_dT, drho_dS, & - tv%eqn_of_state, dom=(/2,kf(i)/)) + tv%eqn_of_state, (/2,kf(i)/) ) ! Sum the reduced gravities to find out how small a density difference ! is negligibly small. diff --git a/src/ice_shelf/MOM_ice_shelf.F90 b/src/ice_shelf/MOM_ice_shelf.F90 index 5da6719b85..59adfae2a8 100644 --- a/src/ice_shelf/MOM_ice_shelf.F90 +++ b/src/ice_shelf/MOM_ice_shelf.F90 @@ -287,6 +287,7 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) real, parameter :: c2_3 = 2.0/3.0 character(len=160) :: mesg ! The text of an error message + integer, dimension(2) :: EOSdom ! The i-computational domain for the equation of state integer :: i, j, is, ie, js, je, ied, jed, it1, it3 if (.not. associated(CS)) call MOM_error(FATAL, "shelf_calc_flux: "// & @@ -369,6 +370,7 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) fluxes%ustar_shelf(i,j) = 0.0 endif ; enddo ; enddo + EOSdom(:) = EOS_domain(G%HI) do j=js,je ! Find the pressure at the ice-ocean interface, averaged only over the ! part of the cell covered by ice shelf. @@ -376,9 +378,9 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) ! Calculate insitu densities and expansion coefficients call calculate_density(state%sst(:,j), state%sss(:,j), p_int, Rhoml(:), & - CS%eqn_of_state, dom=EOS_domain(G%HI)) + CS%eqn_of_state, EOSdom) call calculate_density_derivs(state%sst(:,j), state%sss(:,j), p_int, dR0_dT, dR0_dS, & - CS%eqn_of_state, dom=EOS_domain(G%HI)) + CS%eqn_of_state, EOSdom) do i=is,ie if ((state%ocean_mass(i,j) > US%RZ_to_kg_m2*CS%col_mass_melt_threshold) .and. & diff --git a/src/initialization/MOM_coord_initialization.F90 b/src/initialization/MOM_coord_initialization.F90 index d244146959..7c310ba600 100644 --- a/src/initialization/MOM_coord_initialization.F90 +++ b/src/initialization/MOM_coord_initialization.F90 @@ -291,7 +291,7 @@ subroutine set_coord_from_TS_profile(Rlay, g_prime, GV, US, param_file, eqn_of_s ! These statements set the interface reduced gravities. ! g_prime(1) = g_fs do k=1,nz ; Pref(k) = P_Ref ; enddo - call calculate_density(T0, S0, Pref, Rlay, eqn_of_state, dom=(/1,nz/)) + call calculate_density(T0, S0, Pref, Rlay, eqn_of_state, (/1,nz/) ) do k=2,nz; g_prime(k) = (GV%g_Earth/(GV%Rho0)) * (Rlay(k) - Rlay(k-1)) ; enddo call callTree_leave(trim(mdl)//'()') @@ -371,7 +371,7 @@ subroutine set_coord_from_TS_range(Rlay, g_prime, GV, US, param_file, eqn_of_sta g_prime(1) = g_fs do k=1,nz ; Pref(k) = P_Ref ; enddo - call calculate_density(T0, S0, Pref, Rlay, eqn_of_state, dom=(/k_light,nz/) ) + call calculate_density(T0, S0, Pref, Rlay, eqn_of_state, (/k_light,nz/) ) ! Extrapolate target densities for the variable density mixed and buffer layers. do k=k_light-1,1,-1 Rlay(k) = 2.0*Rlay(k+1) - Rlay(k+2) diff --git a/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 b/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 index a5930f487e..c1b608b16b 100644 --- a/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 +++ b/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 @@ -173,7 +173,6 @@ subroutine mixedlayer_restrat_general(h, uhtr, vhtr, tv, forces, dt, MLD_in, Var real :: vtimescale_diag(SZI_(G),SZJB_(G)) ! meridional directions [T ~> s], stored in 2-D arrays ! for diagnostic purposes. real :: uDml_diag(SZIB_(G),SZJ_(G)), vDml_diag(SZI_(G),SZJB_(G)) - integer :: i, j, k, is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz real, dimension(SZI_(G)) :: rhoSurf, deltaRhoAtKm1, deltaRhoAtK ! Densities [R ~> kg m-3] real, dimension(SZI_(G)) :: dK, dKm1 ! Depths of layer centers [H ~> m or kg m-2]. real, dimension(SZI_(G)) :: pRef_MLD ! A reference pressure for calculating the mixed layer @@ -184,6 +183,8 @@ subroutine mixedlayer_restrat_general(h, uhtr, vhtr, tv, forces, dt, MLD_in, Var real :: hAtVel, zpa, zpb, dh, res_scaling_fac real :: I_LFront ! The inverse of the frontal length scale [L-1 ~> m-1] logical :: proper_averaging, line_is_empty, keep_going, res_upscale + integer, dimension(2) :: EOSdom ! The i-computational domain for the equation of state + integer :: i, j, k, is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz real :: PSI, PSI1, z, BOTTOP, XP, DD ! For the following statement functions ! Stream function as a function of non-dimensional position within mixed-layer (F77 statement function) @@ -205,10 +206,10 @@ subroutine mixedlayer_restrat_general(h, uhtr, vhtr, tv, forces, dt, MLD_in, Var if (CS%MLE_density_diff > 0.) then ! We need to calculate a mixed layer depth, MLD. !! TODO: use derivatives and mid-MLD pressure. Currently this is sigma-0. -AJA pRef_MLD(:) = 0. + EOSdom(:) = EOS_domain(G%HI, halo=1) do j = js-1, je+1 dK(:) = 0.5 * h(:,j,1) ! Depth of center of surface layer - call calculate_density(tv%T(:,j,1), tv%S(:,j,1), pRef_MLD, rhoSurf, tv%eqn_of_state, & - dom=EOS_domain(G%HI, halo=1)) + call calculate_density(tv%T(:,j,1), tv%S(:,j,1), pRef_MLD, rhoSurf, tv%eqn_of_state, EOSdom) deltaRhoAtK(:) = 0. MLD_fast(:,j) = 0. do k = 2, nz @@ -216,8 +217,7 @@ subroutine mixedlayer_restrat_general(h, uhtr, vhtr, tv, forces, dt, MLD_in, Var dK(:) = dK(:) + 0.5 * ( h(:,j,k) + h(:,j,k-1) ) ! Depth of center of layer K ! Mixed-layer depth, using sigma-0 (surface reference pressure) deltaRhoAtKm1(:) = deltaRhoAtK(:) ! Store value from previous iteration of K - call calculate_density(tv%T(:,j,k), tv%S(:,j,k), pRef_MLD, deltaRhoAtK, tv%eqn_of_state, & - dom=EOS_domain(G%HI, halo=1)) + call calculate_density(tv%T(:,j,k), tv%S(:,j,k), pRef_MLD, deltaRhoAtK, tv%eqn_of_state, EOSdom) do i = is-1,ie+1 deltaRhoAtK(i) = deltaRhoAtK(i) - rhoSurf(i) ! Density difference between layer K and surface enddo @@ -300,8 +300,9 @@ subroutine mixedlayer_restrat_general(h, uhtr, vhtr, tv, forces, dt, MLD_in, Var endif p0(:) = 0.0 + EOSdom(:) = EOS_domain(G%HI, halo=1) !$OMP parallel default(none) shared(is,ie,js,je,G,GV,US,htot_fast,Rml_av_fast,tv,p0,h,h_avail,& -!$OMP h_neglect,g_Rho0,I4dt,CS,uhml,uhtr,dt,vhml,vhtr, & +!$OMP h_neglect,g_Rho0,I4dt,CS,uhml,uhtr,dt,vhml,vhtr,EOSdom, & !$OMP utimescale_diag,vtimescale_diag,forces,dz_neglect, & !$OMP htot_slow,MLD_slow,Rml_av_slow,VarMix,I_LFront, & !$OMP res_upscale, & @@ -322,8 +323,7 @@ subroutine mixedlayer_restrat_general(h, uhtr, vhtr, tv, forces, dt, MLD_in, Var h_avail(i,j,k) = max(I4dt*G%areaT(i,j)*(h(i,j,k)-GV%Angstrom_H),0.0) enddo if (keep_going) then - call calculate_density(tv%T(:,j,k), tv%S(:,j,k), p0, rho_ml(:), tv%eqn_of_state, & - dom=EOS_domain(G%HI, halo=1)) + call calculate_density(tv%T(:,j,k), tv%S(:,j,k), p0, rho_ml(:), tv%eqn_of_state, EOSdom) line_is_empty = .true. do i=is-1,ie+1 if (htot_fast(i,j) < MLD_fast(i,j)) then @@ -613,6 +613,7 @@ subroutine mixedlayer_restrat_BML(h, uhtr, vhtr, tv, forces, dt, G, GV, US, CS) real :: uDml_diag(SZIB_(G),SZJ_(G)), vDml_diag(SZI_(G),SZJB_(G)) logical :: use_EOS ! If true, density is calculated from T & S using an equation of state. + integer, dimension(2) :: EOSdom ! The i-computational domain for the equation of state integer :: i, j, k, is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz, nkml 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 ; nkml = GV%nkml @@ -634,7 +635,8 @@ subroutine mixedlayer_restrat_BML(h, uhtr, vhtr, tv, forces, dt, G, GV, US, CS) ! Fix this later for nkml >= 3. p0(:) = 0.0 -!$OMP parallel default(none) shared(is,ie,js,je,G,GV,US,htot,Rml_av,tv,p0,h,h_avail, & + EOSdom(:) = EOS_domain(G%HI, halo=1) +!$OMP parallel default(none) shared(is,ie,js,je,G,GV,US,htot,Rml_av,tv,p0,h,h_avail,EOSdom, & !$OMP h_neglect,g_Rho0,I4dt,CS,uhml,uhtr,dt,vhml,vhtr, & !$OMP utimescale_diag,vtimescale_diag,forces,dz_neglect, & !$OMP uDml_diag,vDml_diag,nkml) & @@ -647,8 +649,7 @@ subroutine mixedlayer_restrat_BML(h, uhtr, vhtr, tv, forces, dt, G, GV, US, CS) htot(i,j) = 0.0 ; Rml_av(i,j) = 0.0 enddo do k=1,nkml - call calculate_density(tv%T(:,j,k), tv%S(:,j,k), p0, Rho0(:), tv%eqn_of_state, & - dom=EOS_domain(G%HI, halo=1)) + call calculate_density(tv%T(:,j,k), tv%S(:,j,k), p0, Rho0(:), tv%eqn_of_state, EOSdom) do i=is-1,ie+1 Rml_av(i,j) = Rml_av(i,j) + h(i,j,k)*Rho0(i) htot(i,j) = htot(i,j) + h(i,j,k) diff --git a/src/parameterizations/lateral/MOM_thickness_diffuse.F90 b/src/parameterizations/lateral/MOM_thickness_diffuse.F90 index 95731b78f0..d988f2bbd5 100644 --- a/src/parameterizations/lateral/MOM_thickness_diffuse.F90 +++ b/src/parameterizations/lateral/MOM_thickness_diffuse.F90 @@ -784,7 +784,7 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV S_u(I) = 0.25*((S(i,j,k) + S(i+1,j,k)) + (S(i,j,k-1) + S(i+1,j,k-1))) enddo call calculate_density_derivs(T_u, S_u, pres_u, drho_dT_u, drho_dS_u, & - tv%eqn_of_state, dom=EOSdom_u) + tv%eqn_of_state, EOSdom_u) endif do I=is-1,ie @@ -1036,7 +1036,7 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV S_v(i) = 0.25*((S(i,j,k) + S(i,j+1,k)) + (S(i,j,k-1) + S(i,j+1,k-1))) enddo call calculate_density_derivs(T_v, S_v, pres_v, drho_dT_v, drho_dS_v, & - tv%eqn_of_state, dom=EOSdom_v) + tv%eqn_of_state, EOSdom_v) endif do i=is,ie if (calc_derivatives) then @@ -1269,7 +1269,7 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV S_u(I) = 0.5*(S(i,j,1) + S(i+1,j,1)) enddo call calculate_density_derivs(T_u, S_u, pres_u, drho_dT_u, drho_dS_u, & - tv%eqn_of_state, dom=EOSdom_u ) + tv%eqn_of_state, EOSdom_u ) endif do I=is-1,ie uhD(I,j,1) = -uhtot(I,j) @@ -1300,7 +1300,7 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV S_v(i) = 0.5*(S(i,j,1) + S(i,j+1,1)) enddo call calculate_density_derivs(T_v, S_v, pres_v, drho_dT_v, drho_dS_v, & - tv%eqn_of_state, dom=EOSdom_v) + tv%eqn_of_state, EOSdom_v) endif do i=is,ie vhD(i,J,1) = -vhtot(i,J) diff --git a/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 b/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 index 10c32350a7..1082bb74e4 100644 --- a/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 +++ b/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 @@ -352,6 +352,7 @@ subroutine bulkmixedlayer(h_3d, u_3d, v_3d, tv, fluxes, dt, ea, eb, G, GV, US, C real :: dt__diag ! A recaled copy of dt_diag (if present) or dt [T ~> s]. logical :: write_diags ! If true, write out diagnostics with this step. logical :: reset_diags ! If true, zero out the accumulated diagnostics. + integer, dimension(2) :: EOSdom ! The i-computational domain for the equation of state integer :: i, j, k, is, ie, js, je, nz, nkmb, n integer :: nsw ! The number of bands of penetrating shortwave radiation. @@ -437,6 +438,7 @@ subroutine bulkmixedlayer(h_3d, u_3d, v_3d, tv, fluxes, dt, ea, eb, G, GV, US, C do k=1,nz ; do i=is,ie ; dKE_CA(i,k) = 0.0 ; cTKE(i,k) = 0.0 ; enddo ; enddo endif max_BL_det(:) = -1 + EOSdom(:) = EOS_domain(G%HI) !$OMP parallel default(shared) firstprivate(dKE_CA,cTKE,h_CA,max_BL_det,p_ref,p_ref_cv) & !$OMP private(h,u,v,h_orig,eps,T,S,opacity_band,d_ea,d_eb,R0,Rcv,ksort, & @@ -466,15 +468,11 @@ subroutine bulkmixedlayer(h_3d, u_3d, v_3d, tv, fluxes, dt, ea, eb, G, GV, US, C do k=1,CS%nkml ; do i=is,ie p_ref(i) = p_ref(i) + 0.5*(GV%H_to_RZ*GV%g_Earth)*h(i,k) enddo ; enddo - call calculate_density_derivs(T(:,1), S(:,1), p_ref, dR0_dT, dR0_dS, tv%eqn_of_state, & - dom=EOS_domain(G%HI)) - call calculate_density_derivs(T(:,1), S(:,1), p_ref_cv, dRcv_dT, dRcv_dS, tv%eqn_of_state, & - dom=EOS_domain(G%HI)) + call calculate_density_derivs(T(:,1), S(:,1), p_ref, dR0_dT, dR0_dS, tv%eqn_of_state, EOSdom) + call calculate_density_derivs(T(:,1), S(:,1), p_ref_cv, dRcv_dT, dRcv_dS, tv%eqn_of_state, EOSdom) do k=1,nz - call calculate_density(T(:,k), S(:,k), p_ref, R0(:,k), tv%eqn_of_state, & - dom=EOS_domain(G%HI)) - call calculate_density(T(:,k), S(:,k), p_ref_cv, Rcv(:,k), tv%eqn_of_state, & - dom=EOS_domain(G%HI)) + call calculate_density(T(:,k), S(:,k), p_ref, R0(:,k), tv%eqn_of_state, EOSdom) + call calculate_density(T(:,k), S(:,k), p_ref_cv, Rcv(:,k), tv%eqn_of_state, EOSdom) enddo if (id_clock_EOS>0) call cpu_clock_end(id_clock_EOS) diff --git a/src/parameterizations/vertical/MOM_diabatic_aux.F90 b/src/parameterizations/vertical/MOM_diabatic_aux.F90 index 61d0d7883a..c1db0849cc 100644 --- a/src/parameterizations/vertical/MOM_diabatic_aux.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_aux.F90 @@ -413,6 +413,7 @@ subroutine insert_brine(h, tv, G, GV, US, fluxes, nkmb, CS, dt, id_brine_lay) real :: h_2d(SZI_(G),SZK_(G)) ! A 2-d slice of h with a minimum thickness [H ~> m to kg m-2] real :: Rcv(SZI_(G),SZK_(G)) ! The coordinate density [R ~> kg m-3] real :: s_new,R_new,t0,scale, cdz + integer, dimension(2) :: EOSdom ! The i-computational domain for the equation of state integer :: i, j, k, is, ie, js, je, nz, ks real :: brine_dz ! minumum thickness over which to distribute brine [H ~> m or kg m-2] @@ -427,6 +428,7 @@ subroutine insert_brine(h, tv, G, GV, US, fluxes, nkmb, CS, dt, id_brine_lay) ! subroutine needs to be revisited.- RWH p_ref_cv(:) = tv%P_Ref + EOSdom(:) = EOS_domain(G%HI) brine_dz = 1.0*GV%m_to_H inject_layer(:,:) = nz @@ -446,8 +448,7 @@ subroutine insert_brine(h, tv, G, GV, US, fluxes, nkmb, CS, dt, id_brine_lay) h_2d(i,k) = MAX(h(i,j,k), GV%Angstrom_H) enddo - call calculate_density(T(:,k), S(:,k), p_ref_cv, Rcv(:,k), tv%eqn_of_state, & - dom=EOS_domain(G%HI)) + call calculate_density(T(:,k), S(:,k), p_ref_cv, Rcv(:,k), tv%eqn_of_state, EOSdom) enddo ! First, try to find an interior layer where inserting all the salt @@ -753,6 +754,7 @@ subroutine diagnoseMLDbyDensityDifference(id_MLD, h, tv, densityDiff, G, GV, US, real :: dH_subML ! Depth below ML over which to diagnose stratification [H ~> m]. real :: aFac ! A nondimensional factor [nondim] real :: ddRho ! A density difference [R ~> kg m-3] + integer, dimension(2) :: EOSdom ! The i-computational domain for the equation of state integer :: i, j, is, ie, js, je, k, nz, id_N2, id_SQ id_N2 = -1 ; if (PRESENT(id_N2subML)) id_N2 = id_N2subML @@ -765,10 +767,10 @@ subroutine diagnoseMLDbyDensityDifference(id_MLD, h, tv, densityDiff, G, GV, US, is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke pRef_MLD(:) = 0.0 + EOSdom(:) = EOS_domain(G%HI) do j=js,je do i=is,ie ; dK(i) = 0.5 * h(i,j,1) * GV%H_to_Z ; enddo ! Depth of center of surface layer - call calculate_density(tv%T(:,j,1), tv%S(:,j,1), pRef_MLD, rhoSurf, tv%eqn_of_state, & - dom=EOS_domain(G%HI)) + call calculate_density(tv%T(:,j,1), tv%S(:,j,1), pRef_MLD, rhoSurf, tv%eqn_of_state, EOSdom) do i=is,ie deltaRhoAtK(i) = 0. MLD(i,j) = 0. @@ -809,8 +811,7 @@ subroutine diagnoseMLDbyDensityDifference(id_MLD, h, tv, densityDiff, G, GV, US, ! Mixed-layer depth, using sigma-0 (surface reference pressure) do i=is,ie ; deltaRhoAtKm1(i) = deltaRhoAtK(i) ; enddo ! Store value from previous iteration of K - call calculate_density(tv%T(:,j,k), tv%S(:,j,k), pRef_MLD, deltaRhoAtK, tv%eqn_of_state, & - dom=EOS_domain(G%HI)) + call calculate_density(tv%T(:,j,k), tv%S(:,j,k), pRef_MLD, deltaRhoAtK, tv%eqn_of_state, EOSdom) do i = is, ie deltaRhoAtK(i) = deltaRhoAtK(i) - rhoSurf(i) ! Density difference between layer K and surface ddRho = deltaRhoAtK(i) - deltaRhoAtKm1(i) @@ -833,10 +834,8 @@ subroutine diagnoseMLDbyDensityDifference(id_MLD, h, tv, densityDiff, G, GV, US, ! T_deeper(i) = tv%T(i,j,nz) ; S_deeper(i) = tv%S(i,j,nz) ! N2_region_set(i) = .true. ! endif - call calculate_density(T_subML, S_subML, pRef_N2, rho_subML, tv%eqn_of_state, & - dom=EOS_domain(G%HI)) - call calculate_density(T_deeper, S_deeper, pRef_N2, rho_deeper, tv%eqn_of_state, & - dom=EOS_domain(G%HI)) + call calculate_density(T_subML, S_subML, pRef_N2, rho_subML, tv%eqn_of_state, EOSdom) + call calculate_density(T_deeper, S_deeper, pRef_N2, rho_deeper, tv%eqn_of_state, EOSdom) do i=is,ie ; if ((G%mask2dT(i,j)>0.5) .and. N2_region_set(i)) then subMLN2(i,j) = gE_rho0 * (rho_deeper(i) - rho_subML(i)) / (GV%H_to_z * dH_N2(i)) endif ; enddo @@ -941,6 +940,7 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t ! [Z T-2 R-1 ~> m4 s-2 kg-1] logical :: calculate_energetics logical :: calculate_buoyancy + integer, dimension(2) :: EOSdom ! The i-computational domain for the equation of state integer :: i, j, is, ie, js, je, k, nz, n, nb character(len=45) :: mesg @@ -956,6 +956,7 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t calculate_buoyancy = present(SkinBuoyFlux) if (calculate_buoyancy) SkinBuoyFlux(:,:) = 0.0 g_Hconv2 = (US%L_to_Z**2*GV%g_Earth * GV%H_to_RZ) * GV%H_to_RZ + EOSdom(:) = EOS_domain(G%HI) if (present(cTKE)) cTKE(:,:,:) = 0.0 if (calculate_buoyancy) then @@ -1011,7 +1012,7 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t pres(i) = pres(i) + d_pres(i) enddo call calculate_specific_vol_derivs(T2d(:,k), tv%S(:,j,k), p_lay(:), & - dSV_dT(:,j,k), dSV_dS(:,j,k), tv%eqn_of_state, dom=EOS_domain(G%HI)) + dSV_dT(:,j,k), dSV_dS(:,j,k), tv%eqn_of_state, EOSdom) do i=is,ie ; dSV_dT_2d(i,k) = dSV_dT(i,j,k) ; enddo enddo pen_TKE_2d(:,:) = 0.0 @@ -1353,7 +1354,7 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t ! Density derivatives call calculate_density_derivs(T2d(:,1), tv%S(:,j,1), SurfPressure, dRhodT, dRhodS, & - tv%eqn_of_state, dom=EOS_domain(G%HI)) + tv%eqn_of_state, EOSdom) ! 1. Adjust netSalt to reflect dilution effect of FW flux ! 2. Add in the SW heating for purposes of calculating the net ! surface buoyancy flux affecting the top layer. diff --git a/src/parameterizations/vertical/MOM_diabatic_driver.F90 b/src/parameterizations/vertical/MOM_diabatic_driver.F90 index 88cd39db45..1ee10cebec 100644 --- a/src/parameterizations/vertical/MOM_diabatic_driver.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_driver.F90 @@ -2012,6 +2012,7 @@ subroutine layered_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_e integer :: dir_flag ! An integer encoding the directions in which to do halo updates. logical :: showCallTree ! If true, show the call tree + integer, dimension(2) :: EOSdom ! The i-computational domain for the equation of state integer :: i, j, k, is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz, nkmb, m, halo integer :: ig, jg ! global indices for testing testing itide point source (BDM) @@ -2680,10 +2681,11 @@ subroutine layered_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_e ! Layer mode sponge if (CS%bulkmixedlayer .and. associated(tv%eqn_of_state)) then do i=is,ie ; p_ref_cv(i) = tv%P_Ref ; enddo + EOSdom(:) = EOS_domain(G%HI) !$OMP parallel do default(shared) do j=js,je call calculate_density(tv%T(:,j,1), tv%S(:,j,1), p_ref_cv, Rcv_ml(:,j), & - tv%eqn_of_state, dom=EOS_domain(G%HI)) + tv%eqn_of_state, EOSdom) enddo call apply_sponge(h, dt, G, GV, US, ea, eb, CS%sponge_CSp, Rcv_ml) else diff --git a/src/parameterizations/vertical/MOM_entrain_diffusive.F90 b/src/parameterizations/vertical/MOM_entrain_diffusive.F90 index 6040026881..d416732ae6 100644 --- a/src/parameterizations/vertical/MOM_entrain_diffusive.F90 +++ b/src/parameterizations/vertical/MOM_entrain_diffusive.F90 @@ -199,6 +199,7 @@ subroutine entrainment_diffusive(h, tv, fluxes, dt, G, GV, US, CS, ea, eb, & logical :: do_any logical :: do_entrain_eakb ! True if buffer layer is entrained logical :: do_i(SZI_(G)), did_i(SZI_(G)), reiterate, correct_density + integer, dimension(2) :: EOSdom ! The i-computational domain for the equation of state integer :: it, i, j, k, is, ie, js, je, nz, K2, kmb integer :: kb(SZI_(G)) ! The value of kb in row j. integer :: kb_min ! The minimum value of kb in the current j-row. @@ -247,6 +248,7 @@ subroutine entrainment_diffusive(h, tv, fluxes, dt, G, GV, US, CS, ea, eb, & else pres(:) = 0.0 endif + EOSdom(:) = EOS_domain(G%HI) !$OMP parallel do default(none) shared(is,ie,js,je,nz,Kd_Lay,G,GV,US,dt,CS,h,tv, & !$OMP kmb,Angstrom,fluxes,K2,h_neglect,tolerance, & @@ -700,8 +702,7 @@ subroutine entrainment_diffusive(h, tv, fluxes, dt, G, GV, US, CS, ea, eb, & call determine_dSkb(h_bl, Sref, Ent_bl, eakb, is, ie, kmb, G, GV, & .true., dS_kb, dS_anom_lim=dS_anom_lim) do k=nz-1,kb_min,-1 - call calculate_density(tv%T(:,j,k), tv%S(:,j,k), pres, Rcv, tv%eqn_of_state, & - dom=EOS_domain(G%HI)) + call calculate_density(tv%T(:,j,k), tv%S(:,j,k), pres, Rcv, tv%eqn_of_state, EOSdom) do i=is,ie if ((k>kb(i)) .and. (F(i,k) > 0.0)) then ! Within a time step, a layer may entrain no more than its @@ -785,8 +786,7 @@ subroutine entrainment_diffusive(h, tv, fluxes, dt, G, GV, US, CS, ea, eb, & else ! not bulkmixedlayer do k=K2,nz-1; - call calculate_density(tv%T(:,j,k), tv%S(:,j,k), pres, Rcv, tv%eqn_of_state, & - dom=EOS_domain(G%HI)) + call calculate_density(tv%T(:,j,k), tv%S(:,j,k), pres, Rcv, tv%eqn_of_state, EOSdom) do i=is,ie ; if (F(i,k) > 0.0) then ! Within a time step, a layer may entrain no more than ! its thickness for correction. This limitation should @@ -852,7 +852,7 @@ subroutine entrainment_diffusive(h, tv, fluxes, dt, G, GV, US, CS, ea, eb, & endif enddo call calculate_density_derivs(T_eos, S_eos, pressure, dRho_dT, dRho_dS, & - tv%eqn_of_state, dom=EOS_domain(G%HI)) + tv%eqn_of_state, EOSdom) do i=is,ie if ((k>kmb) .and. (k m2 or kg2 m-4]. real :: h_neglect ! A thickness that is so small it is usually lost ! in roundoff and can be neglected [H ~> m or kg m-2]. + integer, dimension(2) :: EOSdom ! The i-computational domain for the equation of state integer :: i, k, is, ie, nz is = G%isc ; ie = G%iec ; nz = G%ke @@ -1085,9 +1086,9 @@ subroutine set_Ent_bl(h, dtKd_int, tv, kb, kmb, do_i, G, GV, US, CS, j, Ent_bl, h_neglect = GV%H_subroundoff do i=is,ie ; pres(i) = tv%P_Ref ; enddo + EOSdom(:) = EOS_domain(G%HI) do k=1,kmb - call calculate_density(tv%T(:,j,k), tv%S(:,j,k), pres, Rcv, tv%eqn_of_state, & - dom=EOS_domain(G%HI)) + call calculate_density(tv%T(:,j,k), tv%S(:,j,k), pres, Rcv, tv%eqn_of_state, EOSdom) do i=is,ie h_bl(i,k) = h(i,j,k) + h_neglect Sref(i,k) = Rcv(i) - CS%Rho_sig_off diff --git a/src/parameterizations/vertical/MOM_full_convection.F90 b/src/parameterizations/vertical/MOM_full_convection.F90 index e19a71ac98..1783955d53 100644 --- a/src/parameterizations/vertical/MOM_full_convection.F90 +++ b/src/parameterizations/vertical/MOM_full_convection.F90 @@ -352,6 +352,7 @@ subroutine smoothed_dRdT_dRdS(h, tv, Kddt, dR_dT, dR_dS, G, GV, US, j, p_surf, h real :: h_neglect, h0 ! Negligible thicknesses to allow for zero thicknesses, ! [H ~> m or kg m-2]. real :: h_tr ! The thickness at tracer points, plus h_neglect [H ~> m or kg m-2]. + integer, dimension(2) :: EOSdom ! The i-computational domain for the equation of state integer :: i, k, is, ie, nz if (present(halo)) then @@ -407,20 +408,19 @@ subroutine smoothed_dRdT_dRdS(h, tv, Kddt, dR_dT, dR_dS, G, GV, US, j, p_surf, h else do i=is,ie ; pres(i) = 0.0 ; enddo endif - call calculate_density_derivs(T_f(:,1), S_f(:,1), pres, dR_dT(:,1), dR_dS(:,1), tv%eqn_of_state, & - dom=EOS_domain(G%HI)) + EOSdom(:) = EOS_domain(G%HI) + call calculate_density_derivs(T_f(:,1), S_f(:,1), pres, dR_dT(:,1), dR_dS(:,1), tv%eqn_of_state, EOSdom) do i=is,ie ; pres(i) = pres(i) + h(i,j,1)*(GV%H_to_RZ*GV%g_Earth) ; enddo do K=2,nz do i=is,ie T_EOS(i) = 0.5*(T_f(i,k-1) + T_f(i,k)) S_EOS(i) = 0.5*(S_f(i,k-1) + S_f(i,k)) enddo - call calculate_density_derivs(T_EOS, S_EOS, pres, dR_dT(:,K), dR_dS(:,K), tv%eqn_of_state, & - dom=EOS_domain(G%HI)) + call calculate_density_derivs(T_EOS, S_EOS, pres, dR_dT(:,K), dR_dS(:,K), tv%eqn_of_state, EOSdom) do i=is,ie ; pres(i) = pres(i) + h(i,j,k)*(GV%H_to_RZ*GV%g_Earth) ; enddo enddo call calculate_density_derivs(T_f(:,nz), S_f(:,nz), pres, dR_dT(:,nz+1), dR_dS(:,nz+1), & - tv%eqn_of_state, dom=EOS_domain(G%HI)) + tv%eqn_of_state, EOSdom) end subroutine smoothed_dRdT_dRdS diff --git a/src/parameterizations/vertical/MOM_geothermal.F90 b/src/parameterizations/vertical/MOM_geothermal.F90 index 9106be075e..66116575d5 100644 --- a/src/parameterizations/vertical/MOM_geothermal.F90 +++ b/src/parameterizations/vertical/MOM_geothermal.F90 @@ -199,7 +199,7 @@ subroutine geothermal(h, tv, dt, ea, eb, G, GV, US, CS, halo) if (nkmb > 0) then call calculate_density(tv%T(:,j,nkmb), tv%S(:,j,nkmb), p_Ref(:), Rcv_BL(:), & - tv%eqn_of_state, dom=(/isj-(G%isd-1),iej-(G%isd-1)/)) + tv%eqn_of_state, (/isj-(G%isd-1),iej-(G%isd-1)/) ) else Rcv_BL(:) = -1.0 endif @@ -249,7 +249,7 @@ subroutine geothermal(h, tv, dt, ea, eb, G, GV, US, CS, halo) T2(1) = tv%T(i,j,k) ; S2(1) = tv%S(i,j,k) T2(2) = tv%T(i,j,k_tgt) ; S2(2) = tv%S(i,j,k_tgt) call calculate_density_derivs(T2(:), S2(:), p_Ref(:), dRcv_dT_, dRcv_dS_, & - tv%eqn_of_state, dom=(/1,2/) ) + tv%eqn_of_state, (/1,2/) ) dRcv_dT = 0.5*(dRcv_dT_(1) + dRcv_dT_(2)) endif diff --git a/src/parameterizations/vertical/MOM_internal_tide_input.F90 b/src/parameterizations/vertical/MOM_internal_tide_input.F90 index 0455614790..f5b9e7dbb7 100644 --- a/src/parameterizations/vertical/MOM_internal_tide_input.F90 +++ b/src/parameterizations/vertical/MOM_internal_tide_input.F90 @@ -181,17 +181,19 @@ subroutine find_N2_bottom(h, tv, T_f, S_f, h2, fluxes, G, GV, US, N2_bot) real :: G_Rho0 ! The gravitation acceleration divided by the Boussinesq ! density [Z T-2 R-1 ~> m4 s-2 kg-1]. logical :: do_i(SZI_(G)), do_any + integer, dimension(2) :: EOSdom ! The i-computational domain for the equation of state integer :: i, j, k, is, ie, js, je, nz is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke G_Rho0 = (US%L_to_Z**2*GV%g_Earth) / GV%Rho0 + EOSdom(:) = EOS_domain(G%HI) ! Find the (limited) density jump across each interface. do i=is,ie dRho_int(i,1) = 0.0 ; dRho_int(i,nz+1) = 0.0 enddo !$OMP parallel do default(none) shared(is,ie,js,je,nz,tv,fluxes,G,GV,US,h,T_f,S_f, & -!$OMP h2,N2_bot,G_Rho0) & +!$OMP h2,N2_bot,G_Rho0,EOSdom) & !$OMP private(pres,Temp_Int,Salin_Int,dRho_dT,dRho_dS, & !$OMP hb,dRho_bot,z_from_bot,do_i,h_amp, & !$OMP do_any,dz_int) & @@ -210,7 +212,7 @@ subroutine find_N2_bottom(h, tv, T_f, S_f, h2, fluxes, G, GV, US, N2_bot) Salin_Int(i) = 0.5 * (S_f(i,j,k) + S_f(i,j,k-1)) enddo call calculate_density_derivs(Temp_int, Salin_int, pres, dRho_dT(:), dRho_dS(:), & - tv%eqn_of_state, dom=EOS_domain(G%HI)) + tv%eqn_of_state, EOSdom) do i=is,ie dRho_int(i,K) = max(dRho_dT(i)*(T_f(i,j,k) - T_f(i,j,k-1)) + & dRho_dS(i)*(S_f(i,j,k) - S_f(i,j,k-1)), 0.0) diff --git a/src/parameterizations/vertical/MOM_kappa_shear.F90 b/src/parameterizations/vertical/MOM_kappa_shear.F90 index 153cf50244..107a80b058 100644 --- a/src/parameterizations/vertical/MOM_kappa_shear.F90 +++ b/src/parameterizations/vertical/MOM_kappa_shear.F90 @@ -911,7 +911,7 @@ subroutine kappa_shear_column(kappa, tke, dt, nzc, f2, surface_pres, & Sal_int(K) = 0.5*(Sal(k-1) + Sal(k)) enddo call calculate_density_derivs(T_int, Sal_int, pressure, dbuoy_dT, dbuoy_dS, & - tv%eqn_of_state, scale=-g_R0, dom=(/2,nzc/)) + tv%eqn_of_state, (/2,nzc/), scale=-g_R0 ) else do K=1,nzc+1 ; dbuoy_dT(K) = -g_R0 ; dbuoy_dS(K) = 0.0 ; enddo endif diff --git a/src/parameterizations/vertical/MOM_regularize_layers.F90 b/src/parameterizations/vertical/MOM_regularize_layers.F90 index 072b471bf0..00c8258fb7 100644 --- a/src/parameterizations/vertical/MOM_regularize_layers.F90 +++ b/src/parameterizations/vertical/MOM_regularize_layers.F90 @@ -215,6 +215,7 @@ subroutine regularize_surface(h, tv, dt, ea, eb, G, GV, US, CS) logical :: debug = .false. logical :: fatal_error character(len=256) :: mesg ! Message for error messages. + integer, dimension(2) :: EOSdom ! The i-computational domain for the equation of state integer :: i, j, k, is, ie, js, je, nz, nkmb, nkml, k1, k2, k3, ks, nz_filt, kmax_d_ea is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke @@ -241,6 +242,7 @@ subroutine regularize_surface(h, tv, dt, ea, eb, G, GV, US, CS) I_dtol34 = 1.0 / max(CS%h_def_tol4 - CS%h_def_tol3, 1e-40) p_ref_cv(:) = tv%P_Ref + EOSdom(:) = EOS_domain(G%HI) do j=js-1,je+1 ; do i=is-1,ie+1 e(i,j,1) = 0.0 @@ -308,12 +310,11 @@ subroutine regularize_surface(h, tv, dt, ea, eb, G, GV, US, CS) ! Now restructure the layers. !$OMP parallel do default(private) shared(is,ie,js,je,nz,do_j,def_rat_h,CS,nkmb,G,GV,US, & !$OMP e,I_dtol,h,tv,debug,h_neglect,p_ref_cv,ea, & - !$OMP eb,id_clock_EOS,nkml) + !$OMP eb,id_clock_EOS,nkml,EOSdom) do j=js,je ; if (do_j(j)) then ! call cpu_clock_begin(id_clock_EOS) -! call calculate_density_derivs(T(:,1), S(:,1), p_ref_cv, dRcv_dT, dRcv_dS, tv%eqn_of_state, & -! dom=EOS_domain(G%HI)) +! call calculate_density_derivs(T(:,1), S(:,1), p_ref_cv, dRcv_dT, dRcv_dS, tv%eqn_of_state, EOSdom) ! call cpu_clock_end(id_clock_EOS) do k=1,nz ; do i=is,ie ; d_ea(i,k) = 0.0 ; d_eb(i,k) = 0.0 ; enddo ; enddo @@ -445,8 +446,7 @@ subroutine regularize_surface(h, tv, dt, ea, eb, G, GV, US, CS) if (det_any) then call cpu_clock_begin(id_clock_EOS) do k=1,nkmb - call calculate_density(T_2d(:,k), S_2d(:,k), p_ref_cv, Rcv(:,k), tv%eqn_of_state, & - dom=EOS_domain(G%HI)) + call calculate_density(T_2d(:,k), S_2d(:,k), p_ref_cv, Rcv(:,k), tv%eqn_of_state, EOSdom) enddo call cpu_clock_end(id_clock_EOS) diff --git a/src/parameterizations/vertical/MOM_set_diffusivity.F90 b/src/parameterizations/vertical/MOM_set_diffusivity.F90 index a230cd8237..2ee3f38233 100644 --- a/src/parameterizations/vertical/MOM_set_diffusivity.F90 +++ b/src/parameterizations/vertical/MOM_set_diffusivity.F90 @@ -680,6 +680,7 @@ subroutine find_TKE_to_Kd(h, tv, dRho_int, N2_lay, j, dt, G, GV, US, CS, & real :: hN2pO2 ! h (N^2 + Omega^2), in [Z T-2 ~> m s-2]. logical :: do_i(SZI_(G)) + integer, dimension(2) :: EOSdom ! The i-computational domain for the equation of state integer :: i, k, is, ie, nz, i_rem, kmb, kb_min is = G%isc ; ie = G%iec ; nz = G%ke @@ -713,12 +714,11 @@ subroutine find_TKE_to_Kd(h, tv, dRho_int, N2_lay, j, dt, G, GV, US, CS, & if (CS%bulkmixedlayer) then kmb = GV%nk_rho_varies do i=is,ie ; p_0(i) = 0.0 ; p_ref(i) = tv%P_Ref ; enddo + EOSdom(:) = EOS_domain(G%HI) do k=1,nz - call calculate_density(tv%T(:,j,k), tv%S(:,j,k), p_0, rho_0(:,k), & - tv%eqn_of_state, dom=EOS_domain(G%HI)) + call calculate_density(tv%T(:,j,k), tv%S(:,j,k), p_0, rho_0(:,k), tv%eqn_of_state, EOSdom) enddo - call calculate_density(tv%T(:,j,kmb), tv%S(:,j,kmb), p_ref, Rcv_kmb, & - tv%eqn_of_state, dom=EOS_domain(G%HI)) + call calculate_density(tv%T(:,j,kmb), tv%S(:,j,kmb), p_ref, Rcv_kmb, tv%eqn_of_state, EOSdom) kb_min = kmb+1 do i=is,ie @@ -883,6 +883,7 @@ subroutine find_N2(h, tv, T_f, S_f, fluxes, j, G, GV, US, CS, dRho_int, & real :: H_neglect ! negligibly small thickness, in the same units as h. logical :: do_i(SZI_(G)), do_any + integer, dimension(2) :: EOSdom ! The i-computational domain for the equation of state integer :: i, k, is, ie, nz is = G%isc ; ie = G%iec ; nz = G%ke @@ -900,6 +901,7 @@ subroutine find_N2(h, tv, T_f, S_f, fluxes, j, G, GV, US, CS, dRho_int, & else do i=is,ie ; pres(i) = 0.0 ; enddo endif + EOSdom(:) = EOS_domain(G%HI) do K=2,nz do i=is,ie pres(i) = pres(i) + (GV%g_Earth*GV%H_to_RZ)*h(i,j,k-1) @@ -907,7 +909,7 @@ subroutine find_N2(h, tv, T_f, S_f, fluxes, j, G, GV, US, CS, dRho_int, & Salin_Int(i) = 0.5 * (S_f(i,j,k) + S_f(i,j,k-1)) enddo call calculate_density_derivs(Temp_int, Salin_int, pres, dRho_dT(:,K), dRho_dS(:,K), & - tv%eqn_of_state, dom=EOS_domain(G%HI)) + tv%eqn_of_state, EOSdom) do i=is,ie dRho_int(i,K) = max(dRho_dT(i,K)*(T_f(i,j,k) - T_f(i,j,k-1)) + & dRho_dS(i,K)*(S_f(i,j,k) - S_f(i,j,k-1)), 0.0) @@ -1051,6 +1053,7 @@ subroutine double_diffusion(tv, h, T_f, S_f, j, G, GV, US, CS, Kd_T_dd, Kd_S_dd) real, parameter :: Rrho0 = 1.9 ! limit for double-diffusive density ratio [nondim] + integer, dimension(2) :: EOSdom ! The i-computational domain for the equation of state integer :: i, k, is, ie, nz is = G%isc ; ie = G%iec ; nz = G%ke @@ -1059,6 +1062,7 @@ subroutine double_diffusion(tv, h, T_f, S_f, j, G, GV, US, CS, Kd_T_dd, Kd_S_dd) pres(i) = 0.0 ; Kd_T_dd(i,1) = 0.0 ; Kd_S_dd(i,1) = 0.0 Kd_T_dd(i,nz+1) = 0.0 ; Kd_S_dd(i,nz+1) = 0.0 enddo + EOSdom(:) = EOS_domain(G%HI) do K=2,nz do i=is,ie pres(i) = pres(i) + (GV%g_Earth*GV%H_to_RZ)*h(i,j,k-1) @@ -1066,7 +1070,7 @@ subroutine double_diffusion(tv, h, T_f, S_f, j, G, GV, US, CS, Kd_T_dd, Kd_S_dd) Salin_Int(i) = 0.5 * (S_f(i,j,k-1) + S_f(i,j,k)) enddo call calculate_density_derivs(Temp_int, Salin_int, pres, dRho_dT, dRho_dS, & - tv%eqn_of_state, dom=EOS_domain(G%HI)) + tv%eqn_of_state, EOSdom) do i=is,ie alpha_dT = -1.0*dRho_dT(i) * (T_f(i,j,k-1) - T_f(i,j,k)) @@ -1798,6 +1802,7 @@ subroutine set_density_ratios(h, tv, kb, G, GV, US, CS, j, ds_dsp1, rho_0) real :: Rcv(SZI_(G),SZK_(G)) ! coordinate density in the mixed and buffer layers [R ~> kg m-3] real :: I_Drho ! temporary variable [R-1 ~> m3 kg-1] + integer, dimension(2) :: EOSdom ! The i-computational domain for the equation of state integer :: i, k, k3, is, ie, nz, kmb is = G%isc ; ie = G%iec ; nz = G%ke @@ -1818,9 +1823,9 @@ subroutine set_density_ratios(h, tv, kb, G, GV, US, CS, j, ds_dsp1, rho_0) kmb = GV%nk_rho_varies eps = 0.1 do i=is,ie ; p_ref(i) = tv%P_Ref ; enddo + EOSdom(:) = EOS_domain(G%HI) do k=1,kmb - call calculate_density(tv%T(:,j,k), tv%S(:,j,k), p_ref, Rcv(:,k), tv%eqn_of_state, & - dom=EOS_domain(G%HI)) + call calculate_density(tv%T(:,j,k), tv%S(:,j,k), p_ref, Rcv(:,k), tv%eqn_of_state, EOSdom) enddo do i=is,ie if (kb(i) <= nz-1) then diff --git a/src/parameterizations/vertical/MOM_set_viscosity.F90 b/src/parameterizations/vertical/MOM_set_viscosity.F90 index d1c3a98b68..be16133ed1 100644 --- a/src/parameterizations/vertical/MOM_set_viscosity.F90 +++ b/src/parameterizations/vertical/MOM_set_viscosity.F90 @@ -318,7 +318,7 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, symmetrize) !$OMP parallel do default(shared) do k=1,nkmb ; do j=Jsq,Jeq+1 call calculate_density(tv%T(:,j,k), tv%S(:,j,k), p_ref, Rml(:,j,k), tv%eqn_of_state, & - dom=EOSdom) + EOSdom) enddo ; enddo endif @@ -575,7 +575,7 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, symmetrize) press(i) = press(i) + (GV%H_to_RZ*GV%g_Earth) * h_vel(i,k) enddo ; enddo call calculate_density_derivs(T_EOS, S_EOS, press, dR_dT, dR_dS, tv%eqn_of_state, & - dom=(/is-G%IsdB+1,ie-G%IsdB+1/)) + (/is-G%IsdB+1,ie-G%IsdB+1/) ) endif do i=is,ie ; if (do_i(i)) then @@ -1279,7 +1279,7 @@ subroutine set_viscous_ML(u, v, h, tv, forces, visc, dt, G, GV, US, CS, symmetri S_EOS(I) = (h(i,j,k2)*tv%S(i,j,k2) + h(i+1,j,k2)*tv%S(i+1,j,k2)) * I_2hlay enddo call calculate_density_derivs(T_EOS, S_EOS, press, dR_dT, dR_dS, tv%eqn_of_state, & - dom=(/Isq-G%IsdB+1,Ieq-G%IsdB+1/)) + (/Isq-G%IsdB+1,Ieq-G%IsdB+1/) ) endif do I=Isq,Ieq ; if (do_i(I)) then @@ -1400,7 +1400,7 @@ subroutine set_viscous_ML(u, v, h, tv, forces, visc, dt, G, GV, US, CS, symmetri if (use_EOS) then call calculate_density_derivs(T_EOS, S_EOS, forces%p_surf(:,j), dR_dT, dR_dS, & - tv%eqn_of_state, dom=(/Isq-G%IsdB+1,Ieq-G%IsdB+1/)) + tv%eqn_of_state, (/Isq-G%IsdB+1,Ieq-G%IsdB+1/) ) endif do I=Isq,Ieq ; if (do_i(I)) then @@ -1516,7 +1516,7 @@ subroutine set_viscous_ML(u, v, h, tv, forces, visc, dt, G, GV, US, CS, symmetri S_EOS(i) = (h(i,j,k2)*tv%S(i,j,k2) + h(i,j+1,k2)*tv%S(i,j+1,k2)) * I_2hlay enddo call calculate_density_derivs(T_EOS, S_EOS, press, dR_dT, dR_dS, & - tv%eqn_of_state, dom=(/is-G%IsdB+1,ie-G%IsdB+1/)) + tv%eqn_of_state, (/is-G%IsdB+1,ie-G%IsdB+1/) ) endif do i=is,ie ; if (do_i(i)) then @@ -1637,7 +1637,7 @@ subroutine set_viscous_ML(u, v, h, tv, forces, visc, dt, G, GV, US, CS, symmetri if (use_EOS) then call calculate_density_derivs(T_EOS, S_EOS, forces%p_surf(:,j), dR_dT, dR_dS, & - tv%eqn_of_state, dom=(/is-G%IsdB+1,ie-G%IsdB+1/)) + tv%eqn_of_state, (/is-G%IsdB+1,ie-G%IsdB+1/) ) endif do i=is,ie ; if (do_i(i)) then diff --git a/src/tracer/MOM_neutral_diffusion.F90 b/src/tracer/MOM_neutral_diffusion.F90 index 747d9fb6ae..468d6bb674 100644 --- a/src/tracer/MOM_neutral_diffusion.F90 +++ b/src/tracer/MOM_neutral_diffusion.F90 @@ -285,6 +285,7 @@ subroutine neutral_diffusion_calc_coeffs(G, GV, US, h, T, S, CS) type(neutral_diffusion_CS), pointer :: CS !< Neutral diffusion control structure ! Local variables + integer, dimension(2) :: EOSdom ! The i-computational domain for the equation of state integer :: i, j, k ! Variables used for reconstructions real, dimension(SZK_(G),2) :: ppoly_r_S ! Reconstruction slopes @@ -364,6 +365,7 @@ subroutine neutral_diffusion_calc_coeffs(G, GV, US, h, T, S, CS) enddo ; enddo ; enddo endif + EOSdom(:) = EOS_domain(G%HI, halo=1) do j = G%jsc-1, G%jec+1 ! Interpolate state to interface do i = G%isc-1, G%iec+1 @@ -391,18 +393,18 @@ subroutine neutral_diffusion_calc_coeffs(G, GV, US, h, T, S, CS) do k = 1, G%ke+1 if (CS%ref_pres<0) ref_pres(:) = CS%Pint(:,j,k) call calculate_density_derivs(CS%Tint(:,j,k), CS%Sint(:,j,k), ref_pres, CS%dRdT(:,j,k), & - CS%dRdS(:,j,k), CS%EOS, dom=EOS_domain(G%HI, halo=1)) + CS%dRdS(:,j,k), CS%EOS, EOSdom) enddo else ! Discontinuous reconstruction do k = 1, G%ke if (CS%ref_pres<0) ref_pres(:) = CS%Pint(:,j,k) ! Calculate derivatives for the top interface call calculate_density_derivs(CS%T_i(:,j,k,1), CS%S_i(:,j,k,1), ref_pres, CS%dRdT_i(:,j,k,1), & - CS%dRdS_i(:,j,k,1), CS%EOS, dom=EOS_domain(G%HI, halo=1)) + CS%dRdS_i(:,j,k,1), CS%EOS, EOSdom) if (CS%ref_pres<0) ref_pres(:) = CS%Pint(:,j,k+1) ! Calculate derivatives at the bottom interface call calculate_density_derivs(CS%T_i(:,j,k,2), CS%S_i(:,j,k,2), ref_pres, CS%dRdT_i(:,j,k,2), & - CS%dRdS_i(:,j,k,2), CS%EOS, dom=EOS_domain(G%HI, halo=1)) + CS%dRdS_i(:,j,k,2), CS%EOS, EOSdom) enddo endif enddo diff --git a/src/tracer/MOM_tracer_Z_init.F90 b/src/tracer/MOM_tracer_Z_init.F90 index 5cc420e016..a84814d40a 100644 --- a/src/tracer/MOM_tracer_Z_init.F90 +++ b/src/tracer/MOM_tracer_Z_init.F90 @@ -801,9 +801,9 @@ subroutine determine_temperature(temp, salt, R_tgt, p_ref, niter, land_fill, h, adjust_salt = .true. iter_loop: do itt = 1,niter do k=1, nz - call calculate_density(T(:,k), S(:,k), press, rho(:,k), eos, dom=(/1,nx/)) + call calculate_density(T(:,k), S(:,k), press, rho(:,k), eos, (/1,nx/) ) call calculate_density_derivs(T(:,k), S(:,k), press, drho_dT(:,k), drho_dS(:,k), & - eos, dom=(/1,nx/)) + eos, (/1,nx/) ) enddo do k=k_start,nz ; do i=1,nx @@ -831,9 +831,9 @@ subroutine determine_temperature(temp, salt, R_tgt, p_ref, niter, land_fill, h, if (adjust_salt .and. old_fit) then ; do itt = 1,niter do k=1, nz - call calculate_density(T(:,k), S(:,k), press, rho(:,k), eos, dom=(/1,nx/)) + call calculate_density(T(:,k), S(:,k), press, rho(:,k), eos, (/1,nx/) ) call calculate_density_derivs(T(:,k), S(:,k), press, drho_dT(:,k), drho_dS(:,k), & - eos, dom=(/1,nx/)) + eos, (/1,nx/) ) enddo do k=k_start,nz ; do i=1,nx ! if (abs(rho(i,k)-R_tgt(k))>tol_rho .and. hin(i,k)>h_massless .and. abs(T(i,k)-land_fill) < epsln ) then diff --git a/src/tracer/MOM_tracer_hor_diff.F90 b/src/tracer/MOM_tracer_hor_diff.F90 index 968eb9e718..6898af23da 100644 --- a/src/tracer/MOM_tracer_hor_diff.F90 +++ b/src/tracer/MOM_tracer_hor_diff.F90 @@ -675,6 +675,7 @@ subroutine tracer_epipycnal_ML_diff(h, dt, Tr, ntr, khdt_epi_x, khdt_epi_y, G, & real :: tmp real :: p_ref_cv(SZI_(G)) ! The reference pressure for the coordinate density [R L2 T-2 ~> Pa] + integer, dimension(2) :: EOSdom ! The i-computational domain for the equation of state integer :: k_max, k_min, k_test, itmp integer :: i, j, k, k2, m, is, ie, js, je, nz, nkmb integer :: isd, ied, jsd, jed, IsdB, IedB, k_size @@ -695,13 +696,14 @@ subroutine tracer_epipycnal_ML_diff(h, dt, Tr, ntr, khdt_epi_x, khdt_epi_y, G, & endif do i=is-2,ie+2 ; p_ref_cv(i) = tv%P_Ref ; enddo + EOSdom(:) = EOS_domain(G%HI,halo=2) call do_group_pass(CS%pass_t, G%Domain, clock=id_clock_pass) ! Determine which layers the mixed- and buffer-layers map into... !$OMP parallel do default(shared) do k=1,nkmb ; do j=js-2,je+2 call calculate_density(tv%T(:,j,k),tv%S(:,j,k), p_ref_cv, rho_coord(:,j,k), & - tv%eqn_of_state, dom=EOS_domain(G%HI,halo=2)) + tv%eqn_of_state, EOSdom) enddo ; enddo do j=js-2,je+2 ; do i=is-2,ie+2 diff --git a/src/user/DOME_initialization.F90 b/src/user/DOME_initialization.F90 index 059f747609..f92d2d7ac6 100644 --- a/src/user/DOME_initialization.F90 +++ b/src/user/DOME_initialization.F90 @@ -360,7 +360,7 @@ subroutine DOME_set_OBC_data(OBC, tv, G, GV, US, param_file, tr_Reg) ! USER_initialize_temp_sal. pres(:) = tv%P_Ref ; S0(:) = 35.0 ; T0(1) = 25.0 call calculate_density(T0(1), S0(1), pres(1), rho_guess(1), tv%eqn_of_state) - call calculate_density_derivs(T0, S0, pres, drho_dT, drho_dS, tv%eqn_of_state, dom=(/1,1/)) + call calculate_density_derivs(T0, S0, pres, drho_dT, drho_dS, tv%eqn_of_state, (/1,1/) ) do k=1,nz ; T0(k) = T0(1) + (GV%Rlay(k)-rho_guess(1)) / drho_dT(1) ; enddo do itt=1,6 diff --git a/src/user/ISOMIP_initialization.F90 b/src/user/ISOMIP_initialization.F90 index 5eda807888..0a3cfb3fbe 100644 --- a/src/user/ISOMIP_initialization.F90 +++ b/src/user/ISOMIP_initialization.F90 @@ -362,7 +362,7 @@ subroutine ISOMIP_initialize_temperature_salinity ( T, S, h, G, GV, US, param_fi ! call MOM_mesg(mesg,5) enddo - call calculate_density_derivs(T0, S0, pres, drho_dT, drho_dS, eqn_of_state, dom=(/1,1/)) + call calculate_density_derivs(T0, S0, pres, drho_dT, drho_dS, eqn_of_state, (/1,1/) ) ! write(mesg,*) 'computed drho_dS, drho_dT', drho_dS(1), drho_dT(1) ! call MOM_mesg(mesg,5) call calculate_density(T0(1), S0(1), pres(1), rho_guess(1), eqn_of_state) diff --git a/src/user/RGC_initialization.F90 b/src/user/RGC_initialization.F90 index 8a97ae37a1..70b9fcd4dc 100644 --- a/src/user/RGC_initialization.F90 +++ b/src/user/RGC_initialization.F90 @@ -90,6 +90,7 @@ subroutine RGC_initialize_sponges(G, GV, US, tv, u, v, PF, use_ALE, CSp, ACSp) character(len=40) :: temp_var, salt_var, eta_var, inputdir, h_var character(len=40) :: mod = "RGC_initialize_sponges" ! This subroutine's name. + integer, dimension(2) :: EOSdom ! The i-computational domain for the equation of state integer :: i, j, k, is, ie, js, je, isd, ied, jsd, jed, nz, iscB, iecB, jscB, jecB is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke @@ -211,10 +212,9 @@ subroutine RGC_initialize_sponges(G, GV, US, tv, u, v, PF, use_ALE, CSp, ACSp) ! mixed layer density, which is used in determining which layers can be ! inflated without causing static instabilities. do i=is-1,ie ; pres(i) = tv%P_Ref ; enddo - + EOSdom(:) = EOS_domain(G%HI) do j=js,je - call calculate_density(T(:,j,1), S(:,j,1), pres, tmp(:,j), tv%eqn_of_state, & - dom=EOS_domain(G%HI)) + call calculate_density(T(:,j,1), S(:,j,1), pres, tmp(:,j), tv%eqn_of_state, EOSdom) enddo call set_up_sponge_ML_density(tmp, G, CSp) diff --git a/src/user/benchmark_initialization.F90 b/src/user/benchmark_initialization.F90 index f0206dc262..e32c8b9e41 100644 --- a/src/user/benchmark_initialization.F90 +++ b/src/user/benchmark_initialization.F90 @@ -258,7 +258,7 @@ subroutine benchmark_init_temperature_salinity(T, S, G, GV, US, param_file, & T0(k1) = 29.0 call calculate_density(T0(k1), S0(k1), pres(k1), rho_guess(k1), eqn_of_state) - call calculate_density_derivs(T0, S0, pres, drho_dT, drho_dS, eqn_of_state, dom=(/k1,k1/)) + call calculate_density_derivs(T0, S0, pres, drho_dT, drho_dS, eqn_of_state, (/k1,k1/) ) ! A first guess of the layers' temperatures. ! do k=1,nz diff --git a/src/user/user_change_diffusivity.F90 b/src/user/user_change_diffusivity.F90 index 570adb4ff1..a63e7a2b89 100644 --- a/src/user/user_change_diffusivity.F90 +++ b/src/user/user_change_diffusivity.F90 @@ -72,6 +72,7 @@ subroutine user_change_diff(h, tv, G, GV, US, CS, Kd_lay, Kd_int, T_f, S_f, Kd_i logical :: use_EOS ! If true, density is calculated from T & S using an ! equation of state. logical :: store_Kd_add ! Save the added diffusivity as a diagnostic if true. + integer, dimension(2) :: EOSdom ! The i-computational domain for the equation of state integer :: i, j, k, is, ie, js, je, nz integer :: isd, ied, jsd, jed @@ -104,16 +105,15 @@ subroutine user_change_diff(h, tv, G, GV, US, CS, Kd_lay, Kd_int, T_f, S_f, Kd_i if (store_Kd_add) Kd_int_add(:,:,:) = 0.0 do i=is,ie ; p_ref(i) = tv%P_Ref ; enddo + EOSdom(:) = EOS_domain(G%HI) do j=js,je if (present(T_f) .and. present(S_f)) then do k=1,nz - call calculate_density(T_f(:,j,k), S_f(:,j,k), p_ref, Rcv(:,k), tv%eqn_of_state, & - dom=EOS_domain(G%HI)) + call calculate_density(T_f(:,j,k), S_f(:,j,k), p_ref, Rcv(:,k), tv%eqn_of_state, EOSdom) enddo else do k=1,nz - call calculate_density(tv%T(:,j,k), tv%S(:,j,k), p_ref, Rcv(:,k), tv%eqn_of_state, & - dom=EOS_domain(G%HI)) + call calculate_density(tv%T(:,j,k), tv%S(:,j,k), p_ref, Rcv(:,k), tv%eqn_of_state, EOSdom) enddo endif From 3a817efe9969e6598c0aa8ccd091e35fd2b8f35c Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Mon, 20 Apr 2020 06:18:20 -0400 Subject: [PATCH 217/316] Fixed a diagnostic halo extent Corrected a diagnostic halo extent in a recently added EOS_domain call and added new variables to two openMP directives. All answers are bitwise identical. --- src/diagnostics/MOM_diagnostics.F90 | 2 +- src/parameterizations/vertical/MOM_diabatic_aux.F90 | 4 ++-- src/parameterizations/vertical/MOM_entrain_diffusive.F90 | 2 +- 3 files changed, 4 insertions(+), 4 deletions(-) diff --git a/src/diagnostics/MOM_diagnostics.F90 b/src/diagnostics/MOM_diagnostics.F90 index 38529fb958..ca9ad28b62 100644 --- a/src/diagnostics/MOM_diagnostics.F90 +++ b/src/diagnostics/MOM_diagnostics.F90 @@ -464,7 +464,7 @@ subroutine calculate_diagnostic_fields(u, v, h, uh, vh, tv, ADp, CDp, p_surf, & associated(CS%uhGM_Rlay) .or. associated(CS%vhGM_Rlay)) then if (associated(tv%eqn_of_state)) then - EOSdom(:) = EOS_domain(G%HI) + EOSdom(:) = EOS_domain(G%HI, halo=1) pressure_1d(:) = tv%P_Ref !$OMP parallel do default(shared) do k=1,nz ; do j=js-1,je+1 diff --git a/src/parameterizations/vertical/MOM_diabatic_aux.F90 b/src/parameterizations/vertical/MOM_diabatic_aux.F90 index c1db0849cc..92288db846 100644 --- a/src/parameterizations/vertical/MOM_diabatic_aux.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_aux.F90 @@ -978,8 +978,8 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t !$OMP parallel do default(none) shared(is,ie,js,je,nz,h,tv,nsw,G,GV,US,optics,fluxes, & !$OMP H_limit_fluxes,numberOfGroundings,iGround,jGround,& !$OMP nonPenSW,hGrounding,CS,Idt,aggregate_FW_forcing, & - !$OMP minimum_forcing_depth,evap_CFL_limit,dt, & - !$OMP calculate_buoyancy,netPen_rate,SkinBuoyFlux,GoRho, & + !$OMP minimum_forcing_depth,evap_CFL_limit,dt,EOSdom, & + !$OMP calculate_buoyancy,netPen_rate,SkinBuoyFlux,GoRho, & !$OMP calculate_energetics,dSV_dT,dSV_dS,cTKE,g_Hconv2) & !$OMP private(opacityBand,h2d,T2d,netMassInOut,netMassOut, & !$OMP netHeat,netSalt,Pen_SW_bnd,fractionOfForcing, & diff --git a/src/parameterizations/vertical/MOM_entrain_diffusive.F90 b/src/parameterizations/vertical/MOM_entrain_diffusive.F90 index d416732ae6..4e30756f7b 100644 --- a/src/parameterizations/vertical/MOM_entrain_diffusive.F90 +++ b/src/parameterizations/vertical/MOM_entrain_diffusive.F90 @@ -252,7 +252,7 @@ subroutine entrainment_diffusive(h, tv, fluxes, dt, G, GV, US, CS, ea, eb, & !$OMP parallel do default(none) shared(is,ie,js,je,nz,Kd_Lay,G,GV,US,dt,CS,h,tv, & !$OMP kmb,Angstrom,fluxes,K2,h_neglect,tolerance, & - !$OMP ea,eb,correct_density,Kd_int,Kd_eff, & + !$OMP ea,eb,correct_density,Kd_int,Kd_eff,EOSdom, & !$OMP diff_work,g_2dt, kb_out) & !$OMP firstprivate(kb,ds_dsp1,dsp1_ds,pres,kb_min) & !$OMP private(dtKd,dtKd_int,do_i,Ent_bl,dtKd_kb,h_bl, & From 37d30b596280ea12674537419284dad277ffbc8f Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Mon, 20 Apr 2020 07:08:10 -0400 Subject: [PATCH 218/316] Eliminated the use of GV%mks_g_Earth Eliminated the use GV%mks_g_Earth throughout the MOM6 code. This variable is being retained and is still set to avoid breaking any user code that might be using it. All answers are bitwise identical. --- src/core/MOM_verticalGrid.F90 | 8 ++++---- src/initialization/MOM_coord_initialization.F90 | 16 ++++++++-------- src/parameterizations/vertical/MOM_CVMix_KPP.F90 | 2 +- src/user/MOM_wave_interface.F90 | 14 ++++++++------ 4 files changed, 21 insertions(+), 19 deletions(-) diff --git a/src/core/MOM_verticalGrid.F90 b/src/core/MOM_verticalGrid.F90 index 0608499f92..2823175b23 100644 --- a/src/core/MOM_verticalGrid.F90 +++ b/src/core/MOM_verticalGrid.F90 @@ -93,9 +93,9 @@ subroutine verticalGridInit( param_file, GV, US ) ! Read all relevant parameters and write them to the model log. call log_version(param_file, mdl, version, & "Parameters providing information about the vertical grid.") - call get_param(param_file, mdl, "G_EARTH", GV%mks_g_Earth, & + call get_param(param_file, mdl, "G_EARTH", GV%g_Earth, & "The gravitational acceleration of the Earth.", & - units="m s-2", default = 9.80) + units="m s-2", default = 9.80, scale=US%Z_to_m*US%m_s_to_L_T**2) call get_param(param_file, mdl, "RHO_0", GV%Rho0, & "The mean ocean density used with BOUSSINESQ true to "//& "calculate accelerations and the mass for conservation "//& @@ -127,7 +127,7 @@ subroutine verticalGridInit( param_file, GV, US ) "units of thickness into m.", units="m H-1", default=1.0) GV%H_to_m = GV%H_to_m * H_rescale_factor endif - GV%g_Earth = US%m_to_L**2*US%Z_to_m*US%T_to_s**2 * GV%mks_g_Earth + GV%mks_g_Earth = US%L_T_to_m_s**2*US%m_to_Z * GV%g_Earth #ifdef STATIC_MEMORY_ ! Here NK_ is a macro, while nk is a variable. call get_param(param_file, mdl, "NK", nk, & @@ -156,7 +156,7 @@ subroutine verticalGridInit( param_file, GV, US ) GV%H_to_MKS = GV%H_to_kg_m2 endif GV%H_subroundoff = 1e-20 * max(GV%Angstrom_H,GV%m_to_H*1e-17) - GV%H_to_Pa = GV%mks_g_Earth * GV%H_to_kg_m2 + GV%H_to_Pa = US%L_T_to_m_s**2*US%m_to_Z * GV%g_Earth * GV%H_to_kg_m2 GV%H_to_Z = GV%H_to_m * US%m_to_Z GV%Z_to_H = US%Z_to_m * GV%m_to_H diff --git a/src/initialization/MOM_coord_initialization.F90 b/src/initialization/MOM_coord_initialization.F90 index 7c310ba600..58f58fe828 100644 --- a/src/initialization/MOM_coord_initialization.F90 +++ b/src/initialization/MOM_coord_initialization.F90 @@ -141,7 +141,7 @@ subroutine set_coord_from_gprime(Rlay, g_prime, GV, US, param_file) call get_param(param_file, mdl, "GFS" , g_fs, & "The reduced gravity at the free surface.", units="m s-2", & - default=GV%mks_g_Earth, scale=US%m_s_to_L_T**2*US%Z_to_m) + default=GV%g_Earth*US%L_T_to_m_s**2*US%m_to_Z, scale=US%m_s_to_L_T**2*US%Z_to_m) call get_param(param_file, mdl, "GINT", g_int, & "The reduced gravity across internal interfaces.", & units="m s-2", fail_if_missing=.true., scale=US%m_s_to_L_T**2*US%Z_to_m) @@ -176,7 +176,7 @@ subroutine set_coord_from_layer_density(Rlay, g_prime, GV, US, param_file) call get_param(param_file, mdl, "GFS", g_fs, & "The reduced gravity at the free surface.", units="m s-2", & - default=GV%mks_g_Earth, scale=US%m_s_to_L_T**2*US%Z_to_m) + default=GV%g_Earth*US%L_T_to_m_s**2*US%m_to_Z, scale=US%m_s_to_L_T**2*US%Z_to_m) call get_param(param_file, mdl, "LIGHTEST_DENSITY", Rlay_Ref, & "The reference potential density used for layer 1.", & units="kg m-3", default=US%R_to_kg_m3*GV%Rho0, scale=US%kg_m3_to_R) @@ -228,7 +228,7 @@ subroutine set_coord_from_TS_ref(Rlay, g_prime, GV, US, param_file, eqn_of_state "The initial salinities.", units="PSU", default=35.0) call get_param(param_file, mdl, "GFS", g_fs, & "The reduced gravity at the free surface.", units="m s-2", & - default=GV%mks_g_Earth, scale=US%m_s_to_L_T**2*US%Z_to_m) + default=GV%g_Earth*US%L_T_to_m_s**2*US%m_to_Z, scale=US%m_s_to_L_T**2*US%Z_to_m) call get_param(param_file, mdl, "GINT", g_int, & "The reduced gravity across internal interfaces.", & units="m s-2", fail_if_missing=.true., scale=US%m_s_to_L_T**2*US%Z_to_m) @@ -274,7 +274,7 @@ subroutine set_coord_from_TS_profile(Rlay, g_prime, GV, US, param_file, eqn_of_s call get_param(param_file, mdl, "GFS", g_fs, & "The reduced gravity at the free surface.", units="m s-2", & - default=GV%mks_g_Earth, scale=US%m_s_to_L_T**2*US%Z_to_m) + default=GV%g_Earth*US%L_T_to_m_s**2*US%m_to_Z, scale=US%m_s_to_L_T**2*US%Z_to_m) call get_param(param_file, mdl, "COORD_FILE", coord_file, & "The file from which the coordinate temperatures and "//& "salinities are read.", fail_if_missing=.true.) @@ -355,7 +355,7 @@ subroutine set_coord_from_TS_range(Rlay, g_prime, GV, US, param_file, eqn_of_sta call get_param(param_file, mdl, "GFS", g_fs, & "The reduced gravity at the free surface.", units="m s-2", & - default=GV%mks_g_Earth, scale=US%m_s_to_L_T**2*US%Z_to_m) + default=GV%g_Earth*US%L_T_to_m_s**2*US%m_to_Z, scale=US%m_s_to_L_T**2*US%Z_to_m) k_light = GV%nk_rho_varies + 1 @@ -402,7 +402,7 @@ subroutine set_coord_from_file(Rlay, g_prime, GV, US, param_file) call get_param(param_file, mdl, "GFS", g_fs, & "The reduced gravity at the free surface.", units="m s-2", & - default=GV%mks_g_Earth, scale=US%m_s_to_L_T**2*US%Z_to_m) + default=GV%g_Earth*US%L_T_to_m_s**2*US%m_to_Z, scale=US%m_s_to_L_T**2*US%Z_to_m) call get_param(param_file, mdl, "INPUTDIR", inputdir, default=".") inputdir = slasher(inputdir) call get_param(param_file, mdl, "COORD_FILE", coord_file, & @@ -458,7 +458,7 @@ subroutine set_coord_linear(Rlay, g_prime, GV, US, param_file) units="kg m-3", default=2.0, scale=US%kg_m3_to_R) call get_param(param_file, mdl, "GFS", g_fs, & "The reduced gravity at the free surface.", units="m s-2", & - default=GV%mks_g_Earth, scale=US%m_s_to_L_T**2*US%Z_to_m) + default=GV%g_Earth*US%L_T_to_m_s**2*US%m_to_Z, scale=US%m_s_to_L_T**2*US%Z_to_m) ! This following sets the target layer densities such that a the ! surface interface has density Rlay_ref and the bottom @@ -496,7 +496,7 @@ subroutine set_coord_to_none(Rlay, g_prime, GV, US, param_file) call get_param(param_file, mdl, "GFS" , g_fs, & "The reduced gravity at the free surface.", units="m s-2", & - default=GV%mks_g_Earth, scale=US%m_s_to_L_T**2*US%Z_to_m) + default=GV%g_Earth*US%L_T_to_m_s**2*US%m_to_Z, scale=US%m_s_to_L_T**2*US%Z_to_m) g_prime(1) = g_fs do k=2,nz ; g_prime(k) = 0. ; enddo diff --git a/src/parameterizations/vertical/MOM_CVMix_KPP.F90 b/src/parameterizations/vertical/MOM_CVMix_KPP.F90 index 21d7259032..ea187f86f9 100644 --- a/src/parameterizations/vertical/MOM_CVMix_KPP.F90 +++ b/src/parameterizations/vertical/MOM_CVMix_KPP.F90 @@ -960,7 +960,7 @@ subroutine KPP_compute_BLD(CS, G, GV, US, h, Temp, Salt, u, v, EOS, uStar, buoyF #endif ! some constants - GoRho = GV%mks_g_Earth / GV%Rho0 + GoRho = US%L_T_to_m_s**2*US%m_to_Z * GV%g_Earth / GV%Rho0 buoy_scale = US%L_to_m**2*US%s_to_T**3 ! loop over horizontal points on processor diff --git a/src/user/MOM_wave_interface.F90 b/src/user/MOM_wave_interface.F90 index 815e4fa361..da181c5eca 100644 --- a/src/user/MOM_wave_interface.F90 +++ b/src/user/MOM_wave_interface.F90 @@ -1035,7 +1035,7 @@ subroutine get_StokesSL_LiFoxKemper(ustar, hbl, GV, US, UStokes_SL, LA) ! ! peak frequency (PM, Bouws, 1998) tmp = 2.0 * PI * u19p5_to_u10 * u10 - fp = 0.877 * GV%mks_g_Earth / tmp + fp = 0.877 * US%L_T_to_m_s**2*US%m_to_Z * GV%g_Earth / tmp ! ! mean frequency fm = fm_into_fp * fp @@ -1168,23 +1168,25 @@ subroutine DHH85_mid(GV, US, zpt, UStokes) real :: ann, Bnn, Snn, Cnn, Dnn real :: omega_peak, omega, u10, WA, domega real :: omega_min, omega_max, wavespec, Stokes + real :: g_Earth ! Gravitational acceleration [m s-2] integer :: Nomega, OI WA = WaveAge u10 = WaveWind + g_Earth = US%L_T_to_m_s**2*US%m_to_Z * GV%g_Earth !/ omega_min = 0.1 ! Hz ! Cut off at 30cm for now... - omega_max = 10. ! ~sqrt(0.2*GV%mks_g_Earth*2*pi/0.3) + omega_max = 10. ! ~sqrt(0.2*g_Earth*2*pi/0.3) NOmega = 1000 domega = (omega_max-omega_min)/real(NOmega) ! if (WaveAgePeakFreq) then - omega_peak = GV%mks_g_Earth / (WA * u10) + omega_peak = g_Earth / (WA * u10) else - omega_peak = 2. * pi * 0.13 * GV%mks_g_Earth / U10 + omega_peak = 2. * pi * 0.13 * g_Earth / U10 endif !/ Ann = 0.006 * WaveAge**(-0.55) @@ -1200,11 +1202,11 @@ subroutine DHH85_mid(GV, US, zpt, UStokes) do oi = 1,nomega-1 Dnn = exp ( -0.5 * (omega-omega_peak)**2 / (Snn**2 * omega_peak**2) ) ! wavespec units = m2s - wavespec = (Ann * GV%mks_g_Earth**2 / (omega_peak*omega**4 ) ) * & + wavespec = (Ann * g_Earth**2 / (omega_peak*omega**4 ) ) * & exp(-bnn*(omega_peak/omega)**4)*Cnn**Dnn ! Stokes units m (multiply by frequency range for units of m/s) Stokes = 2.0 * wavespec * omega**3 * & - exp( 2.0 * omega**2 * US%Z_to_m*zpt / GV%mks_g_Earth) / GV%mks_g_Earth + exp( 2.0 * omega**2 * US%Z_to_m*zpt / g_Earth) / g_Earth UStokes = UStokes + Stokes*domega omega = omega + domega enddo From 18b21938bd97f852f64ae109620abef47f06d72e Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Mon, 20 Apr 2020 11:57:07 -0400 Subject: [PATCH 219/316] Fixed compile time bugs in mom_surface_forcing_mct Corrected compile time errors, related to an incomplete implementation of the pressure rescaling in mom_surface_forcing_mct.F90. With this fix, the changes relative to dev/gfdl are now similar between mom_surface_forcing_mct.F90 and the equivalent files for the other couplers. All answers in the MOM6-examples test cases are bitwise identical. --- config_src/mct_driver/mom_surface_forcing_mct.F90 | 12 ++++-------- 1 file changed, 4 insertions(+), 8 deletions(-) diff --git a/config_src/mct_driver/mom_surface_forcing_mct.F90 b/config_src/mct_driver/mom_surface_forcing_mct.F90 index c017ecbba5..12fe940ead 100644 --- a/config_src/mct_driver/mom_surface_forcing_mct.F90 +++ b/config_src/mct_driver/mom_surface_forcing_mct.F90 @@ -527,14 +527,12 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, 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) -US%kg_m3_to_R*US%m_s_to_L_T**2*IOB%p(i-i0,j-j0) + fluxes%p_surf_full(i,j) = G%mask2dT(i,j) * US%kg_m3_to_R*US%m_s_to_L_T**2*IOB%p(i-i0,j-j0) fluxes%p_surf(i,j) = MIN(fluxes%p_surf_full(i,j),CS%max_p_surf) enddo; enddo else do j=js,je ; do i=is,ie - fluxes%p_surf_full(i,j) = G%mask2dT(i,j) * IOB%p(i-i0,j-j0) -US%kg_m3_to_R*US%m_s_to_L_T**2*IOB%p(i-i0,j-j0) + fluxes%p_surf_full(i,j) = G%mask2dT(i,j) * US%kg_m3_to_R*US%m_s_to_L_T**2*IOB%p(i-i0,j-j0) fluxes%p_surf(i,j) = fluxes%p_surf_full(i,j) enddo; enddo endif @@ -688,14 +686,12 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS) 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) -US%kg_m3_to_R*US%m_s_to_L_T**2*IOB%p(i-i0,j-j0) + forces%p_surf_full(i,j) = G%mask2dT(i,j) * US%kg_m3_to_R*US%m_s_to_L_T**2*IOB%p(i-i0,j-j0) forces%p_surf(i,j) = MIN(forces%p_surf_full(i,j),CS%max_p_surf) enddo ; enddo else do j=js,je ; do i=is,ie - forces%p_surf_full(i,j) = G%mask2dT(i,j) * IOB%p(i-i0,j-j0) -US%kg_m3_to_R*US%m_s_to_L_T**2*IOB%p(i-i0,j-j0) + forces%p_surf_full(i,j) = G%mask2dT(i,j) * US%kg_m3_to_R*US%m_s_to_L_T**2*IOB%p(i-i0,j-j0) forces%p_surf(i,j) = forces%p_surf_full(i,j) enddo ; enddo endif From f5eb17194d9e5daf1536ae63fbed18e23d17f3f6 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Mon, 20 Apr 2020 14:45:42 -0400 Subject: [PATCH 220/316] Eliminated some US args in MOM_neutral_diffusion Removed unused US arguments to routines in MOM_neutral_diffusion.F90. All answers are bitwise identical, but some internal interfaces have one fewer argument, and have been returned to their form in the dev/gfdl version. --- src/tracer/MOM_neutral_diffusion.F90 | 134 +++++++++++++-------------- 1 file changed, 65 insertions(+), 69 deletions(-) diff --git a/src/tracer/MOM_neutral_diffusion.F90 b/src/tracer/MOM_neutral_diffusion.F90 index 468d6bb674..ac7324c143 100644 --- a/src/tracer/MOM_neutral_diffusion.F90 +++ b/src/tracer/MOM_neutral_diffusion.F90 @@ -19,7 +19,7 @@ module MOM_neutral_diffusion use MOM_remapping, only : extract_member_remapping_CS, build_reconstructions_1d use MOM_remapping, only : average_value_ppoly, remappingSchemesDoc, remappingDefaultScheme use MOM_tracer_registry, only : tracer_registry_type, tracer_type -use MOM_unit_scaling, only : unit_scale_type, unit_scaling_init +use MOM_unit_scaling, only : unit_scale_type use MOM_verticalGrid, only : verticalGrid_type use polynomial_functions, only : evaluation_polynomial, first_derivative_polynomial use PPM_functions, only : PPM_reconstruction, PPM_boundary_extrapolation @@ -86,6 +86,8 @@ module MOM_neutral_diffusion real, allocatable, dimension(:,:,:,:) :: dRdS_i !< dRho/dS [R ppt-1 ~> kg m-3 ppt-1] 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 + real :: R_to_kg_m3 = 1.0 !< A rescaling factor translating density to kg m-3 for + !! use in diagnostic messages [kg m-3 R-1 ~> 1]. type(diag_ctrl), pointer :: diag => NULL() !< A structure that is used to !! regulate the timing of diagnostic output. integer :: neutral_pos_method !< Method to find the position of a neutral surface within the layer @@ -226,6 +228,9 @@ logical function neutral_diffusion_init(Time, G, US, param_file, diag, EOS, diab default = .true.) endif + ! Store a rescaling factor for use in diagnostic messages. + CS%R_to_kg_m3 = US%R_to_kg_m3 + if (CS%interior_only) then call extract_diabatic_member(diabatic_CSp, KPP_CSp=CS%KPP_CSp) call extract_diabatic_member(diabatic_CSp, energetic_PBL_CSp=CS%energetic_PBL_CSp) @@ -411,7 +416,7 @@ subroutine neutral_diffusion_calc_coeffs(G, GV, US, h, T, S, CS) if (.not. CS%continuous_reconstruction) then do j = G%jsc-1, G%jec+1 ; do i = G%isc-1, G%iec+1 - call mark_unstable_cells( CS, G%ke, CS%T_i(i,j,:,:), CS%S_i(i,j,:,:), CS%P_i(i,j,:,:), US, CS%stable_cell(i,j,:) ) + call mark_unstable_cells( CS, G%ke, CS%T_i(i,j,:,:), CS%S_i(i,j,:,:), CS%P_i(i,j,:,:), CS%stable_cell(i,j,:) ) if (CS%interior_only) then if (.not. CS%stable_cell(i,j,k_bot(i,j))) zeta_bot(i,j) = -1. ! set values in the surface and bottom boundary layer to false. @@ -443,7 +448,7 @@ subroutine neutral_diffusion_calc_coeffs(G, GV, US, h, T, S, CS) CS%uPoL(I,j,:), CS%uPoR(I,j,:), CS%uKoL(I,j,:), CS%uKoR(I,j,:), CS%uhEff(I,j,:), & k_bot(I,j), k_bot(I+1,j), 1.-zeta_bot(I,j), 1.-zeta_bot(I+1,j)) else - call find_neutral_surface_positions_discontinuous(CS, US, G%ke, & + call find_neutral_surface_positions_discontinuous(CS, G%ke, & CS%P_i(i,j,:,:), h(i,j,:), CS%T_i(i,j,:,:), CS%S_i(i,j,:,:), CS%ppoly_coeffs_T(i,j,:,:), & CS%ppoly_coeffs_S(i,j,:,:),CS%stable_cell(i,j,:), & CS%P_i(i+1,j,:,:), h(i+1,j,:), CS%T_i(i+1,j,:,:), CS%S_i(i+1,j,:,:), CS%ppoly_coeffs_T(i+1,j,:,:), & @@ -464,7 +469,7 @@ subroutine neutral_diffusion_calc_coeffs(G, GV, US, h, T, S, CS) CS%vPoL(i,J,:), CS%vPoR(i,J,:), CS%vKoL(i,J,:), CS%vKoR(i,J,:), CS%vhEff(i,J,:), & k_bot(i,J), k_bot(i,J+1), 1.-zeta_bot(i,J), 1.-zeta_bot(i,J+1)) else - call find_neutral_surface_positions_discontinuous(CS, US, G%ke, & + call find_neutral_surface_positions_discontinuous(CS, G%ke, & CS%P_i(i,j,:,:), h(i,j,:), CS%T_i(i,j,:,:), CS%S_i(i,j,:,:), CS%ppoly_coeffs_T(i,j,:,:), & CS%ppoly_coeffs_S(i,j,:,:),CS%stable_cell(i,j,:), & CS%P_i(i,j+1,:,:), h(i,j+1,:), CS%T_i(i,j+1,:,:), CS%S_i(i,j+1,:,:), CS%ppoly_coeffs_T(i,j+1,:,:), & @@ -1160,13 +1165,12 @@ end function interpolate_for_nondim_position !> Higher order version of find_neutral_surface_positions. Returns positions within left/right columns !! of combined interfaces using intracell reconstructions of T/S. Note that the polynomial reconstrcutions !! of T and S are optional to aid with unit testing, but will always be passed otherwise -subroutine find_neutral_surface_positions_discontinuous(CS, US, nk, & +subroutine find_neutral_surface_positions_discontinuous(CS, nk, & Pres_l, hcol_l, Tl, Sl, ppoly_T_l, ppoly_S_l, stable_l, & Pres_r, hcol_r, Tr, Sr, ppoly_T_r, ppoly_S_r, stable_r, & PoL, PoR, KoL, KoR, hEff, zeta_bot_L, zeta_bot_R, k_bot_L, k_bot_R, hard_fail_heff) type(neutral_diffusion_CS), intent(inout) :: CS !< Neutral diffusion control structure - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type integer, intent(in) :: nk !< Number of levels real, dimension(nk,2), intent(in) :: Pres_l !< Left-column interface pressure [R L2 T-2 ~> Pa] real, dimension(nk), intent(in) :: hcol_l !< Left-column layer thicknesses [H ~> m or kg m-2] @@ -1284,12 +1288,12 @@ subroutine find_neutral_surface_positions_discontinuous(CS, US, nk, & ! For convenience, the left column uses the searched "from" interface variables, and the right column ! uses the searched 'to'. These will get reset in subsequent calc_delta_rho calls - call calc_delta_rho_and_derivs(CS, US, & + call calc_delta_rho_and_derivs(CS, & Tr(kl_right, ki_right), Sr(kl_right, ki_right), Pres_r(kl_right,ki_right), & Tl(kl_left, ki_left), Sl(kl_left, ki_left) , Pres_l(kl_left,ki_left), & dRho) if (CS%debug) write(stdout,'(A,I2,A,E12.4,A,I2,A,I2,A,I2,A,I2)') & - "k_surface=",k_surface, " dRho=",US%R_to_kg_m3*dRho, & + "k_surface=",k_surface, " dRho=",CS%R_to_kg_m3*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 @@ -1313,7 +1317,7 @@ subroutine find_neutral_surface_positions_discontinuous(CS, US, nk, & ! Position of the right interface is known and all quantities are fixed PoR(k_surface) = ki_right - 1. KoR(k_surface) = kl_right - PoL(k_surface) = search_other_column(CS, US, k_surface, lastP_left, & + PoL(k_surface) = search_other_column(CS, k_surface, lastP_left, & Tr(kl_right, ki_right), Sr(kl_right, ki_right), Pres_r(kl_right, ki_right), & Tl(kl_left,1), Sl(kl_left,1), Pres_l(kl_left,1), & Tl(kl_left,2), Sl(kl_left,2), Pres_l(kl_left,2), & @@ -1336,7 +1340,7 @@ subroutine find_neutral_surface_positions_discontinuous(CS, US, nk, & ! Position of the right interface is known and all quantities are fixed PoL(k_surface) = ki_left - 1. KoL(k_surface) = kl_left - PoR(k_surface) = search_other_column(CS, US, k_surface, lastP_right, & + PoR(k_surface) = search_other_column(CS, k_surface, lastP_right, & Tl(kl_left, ki_left), Sl(kl_left, ki_left), Pres_l(kl_left, ki_left), & Tr(kl_right,1), Sr(kl_right,1), Pres_r(kl_right,1), & Tr(kl_right,2), Sr(kl_right,2), Pres_r(kl_right,2), & @@ -1396,30 +1400,28 @@ subroutine find_neutral_surface_positions_discontinuous(CS, US, nk, & end subroutine find_neutral_surface_positions_discontinuous !> Sweep down through the column and mark as stable if the bottom interface of a cell is denser than the top -subroutine mark_unstable_cells(CS, nk, T, S, P, US, stable_cell) +subroutine mark_unstable_cells(CS, nk, T, S, P, stable_cell) type(neutral_diffusion_CS), intent(inout) :: CS !< Neutral diffusion control structure integer, intent(in) :: nk !< Number of levels in a column real, dimension(nk,2), intent(in) :: T !< Temperature at interfaces [degC] real, dimension(nk,2), intent(in) :: S !< Salinity at interfaces [ppt] real, dimension(nk,2), intent(in) :: P !< Pressure at interfaces [R L2 T-2 ~> Pa] - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type logical, dimension(nk), intent( out) :: stable_cell !< True if this cell is unstably stratified integer :: k, first_stable, prev_stable real :: delta_rho ! A density difference [R ~> kg m-3] do k = 1,nk - call calc_delta_rho_and_derivs( CS, US, T(k,2), S(k,2), max(P(k,2), CS%ref_pres), & - T(k,1), S(k,1), max(P(k,1), CS%ref_pres), delta_rho ) + call calc_delta_rho_and_derivs( CS, T(k,2), S(k,2), max(P(k,2), CS%ref_pres), & + T(k,1), S(k,1), max(P(k,1), CS%ref_pres), delta_rho ) stable_cell(k) = (delta_rho > 0.) enddo end subroutine mark_unstable_cells !> Searches the "other" (searched) column for the position of the neutral surface -real function search_other_column(CS, US, ksurf, pos_last, T_from, S_from, P_from, T_top, S_top, P_top, & - T_bot, S_bot, P_bot, T_poly, S_poly ) result(pos) +real function search_other_column(CS, ksurf, pos_last, T_from, S_from, P_from, T_top, S_top, P_top, & + T_bot, S_bot, P_bot, T_poly, S_poly ) result(pos) type(neutral_diffusion_CS), intent(in ) :: CS !< Neutral diffusion control structure - type(unit_scale_type), intent(in ) :: US !< A dimensional unit scaling type integer, intent(in ) :: ksurf !< Current index of neutral surface real, intent(in ) :: pos_last !< Last position within the current layer, used as the lower !! bound in the root finding algorithm [nondim] @@ -1443,12 +1445,12 @@ real function search_other_column(CS, US, ksurf, pos_last, T_from, S_from, P_fro ! Calculate the differencei in density at the tops or the bottom if (CS%neutral_pos_method == 1 .or. CS%neutral_pos_method == 3) then - call calc_delta_rho_and_derivs(CS, US, T_top, S_top, P_top, T_from, S_from, P_from, dRhoTop) - call calc_delta_rho_and_derivs(CS, US, T_bot, S_bot, P_bot, T_from, S_from, P_from, dRhoBot) + call calc_delta_rho_and_derivs(CS, T_top, S_top, P_top, T_from, S_from, P_from, dRhoTop) + call calc_delta_rho_and_derivs(CS, T_bot, S_bot, P_bot, T_from, S_from, P_from, dRhoBot) elseif (CS%neutral_pos_method == 2) then - call calc_delta_rho_and_derivs(CS, US, T_top, S_top, P_top, T_from, S_from, P_from, dRhoTop, & + call calc_delta_rho_and_derivs(CS, T_top, S_top, P_top, T_from, S_from, P_from, dRhoTop, & dRdT_top, dRdS_top, dRdT_from, dRdS_from) - call calc_delta_rho_and_derivs(CS, US, T_bot, S_bot, P_bot, T_from, S_from, P_from, dRhoBot, & + call calc_delta_rho_and_derivs(CS, T_bot, S_bot, P_bot, T_from, S_from, P_from, dRhoBot, & dRdT_bot, dRdS_bot, dRdT_from, dRdS_from) endif @@ -1480,7 +1482,7 @@ real function search_other_column(CS, US, ksurf, pos_last, T_from, S_from, P_fro pos = find_neutral_pos_linear( CS, pos_last, T_from, S_from, dRdT_from, dRdS_from, & dRdT_top, dRdS_top, dRdT_bot, dRdS_bot, T_poly, S_poly ) elseif (CS%neutral_pos_method == 3) then - pos = find_neutral_pos_full( CS, US, pos_last, T_from, S_from, P_from, P_top, P_bot, T_poly, S_poly) + pos = find_neutral_pos_full( CS, pos_last, T_from, S_from, P_from, P_top, P_bot, T_poly, S_poly) endif end function search_other_column @@ -1641,9 +1643,8 @@ end function find_neutral_pos_linear !> Use the full equation of state to calculate the difference in locally referenced potential density. The derivatives !! in this case are not trivial to calculate, so instead we use a regula falsi method -function find_neutral_pos_full( CS, US, z0, T_ref, S_ref, P_ref, P_top, P_bot, ppoly_T, ppoly_S ) result( z ) +function find_neutral_pos_full( CS, z0, T_ref, S_ref, P_ref, P_top, P_bot, ppoly_T, ppoly_S ) result( z ) type(neutral_diffusion_CS),intent(in) :: CS !< Control structure with parameters for this module - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real, intent(in) :: z0 !< Lower bound of position, also serves as the !! initial guess [nondim] real, intent(in) :: T_ref !< Temperature at the searched from interface [degC] @@ -1676,13 +1677,13 @@ function find_neutral_pos_full( CS, US, z0, T_ref, S_ref, P_ref, P_top, P_bot, p Tb = evaluation_polynomial( ppoly_T, nterm, b ) Sb = evaluation_polynomial( ppoly_S, nterm, b ) Pb = P_top*(1.-b) + P_bot*b - call calc_delta_rho_and_derivs(CS, US, Tb, Sb, Pb, T_ref, S_ref, P_ref, drho_b) + call calc_delta_rho_and_derivs(CS, Tb, Sb, Pb, T_ref, S_ref, P_ref, drho_b) ! Calculate drho at the maximum bound Tc = evaluation_polynomial( ppoly_T, nterm, 1. ) Sc = evaluation_polynomial( ppoly_S, nterm, 1. ) Pc = P_Bot - call calc_delta_rho_and_derivs(CS, US, Tc, Sc, Pc, T_ref, S_ref, P_ref, drho_c) + call calc_delta_rho_and_derivs(CS, Tc, Sc, Pc, T_ref, S_ref, P_ref, drho_c) if (drho_b >= 0.) then z = z0 @@ -1702,7 +1703,7 @@ function find_neutral_pos_full( CS, US, z0, T_ref, S_ref, P_ref, P_top, P_bot, p Ta = evaluation_polynomial( ppoly_T, nterm, a ) Sa = evaluation_polynomial( ppoly_S, nterm, a ) Pa = P_top*(1.-a) + P_bot*a - call calc_delta_rho_and_derivs(CS, US, Ta, Sa, Pa, T_ref, S_ref, P_ref, drho_a) + call calc_delta_rho_and_derivs(CS, Ta, Sa, Pa, T_ref, S_ref, P_ref, drho_a) if (ABS(drho_a) < CS%drho_tol) then z = a return @@ -1735,10 +1736,9 @@ function find_neutral_pos_full( CS, US, z0, T_ref, S_ref, P_ref, P_top, P_bot, p end function find_neutral_pos_full !> Calculate the difference in density between two points in a variety of ways -subroutine calc_delta_rho_and_derivs(CS, US, T1, S1, p1_in, T2, S2, p2_in, drho, & +subroutine calc_delta_rho_and_derivs(CS, T1, S1, p1_in, T2, S2, p2_in, drho, & drdt1_out, drds1_out, drdt2_out, drds2_out ) type(neutral_diffusion_CS) :: CS !< Neutral diffusion control structure - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real, intent(in ) :: T1 !< Temperature at point 1 [degC] real, intent(in ) :: S1 !< Salinity at point 1 [ppt] real, intent(in ) :: p1_in !< Pressure at point 1 [R L2 T-2 ~> Pa] @@ -2349,7 +2349,6 @@ logical function ndiff_unit_tests_discontinuous(verbose) real, dimension(ns-1) :: hEff, Flx type(neutral_diffusion_CS) :: CS !< Neutral diffusion control structure type(EOS_type), pointer :: EOS !< Structure for linear equation of state - type(unit_scale_type), pointer :: US => NULL() !< A dimensional unit scaling type type(remapping_CS), pointer :: remap_CS !< Remapping control structure (PLM) real, dimension(nk,2) :: ppoly_T_l, ppoly_T_r ! Linear reconstruction for T real, dimension(nk,2) :: ppoly_S_l, ppoly_S_r ! Linear reconstruction for S @@ -2370,7 +2369,6 @@ logical function ndiff_unit_tests_discontinuous(verbose) ! Unit tests for find_neutral_surface_positions_discontinuous ! Salinity is 0 for all these tests allocate(CS%EOS) - call unit_scaling_init(US=US) call EOS_manual_init(CS%EOS, form_of_EOS=EOS_LINEAR, dRho_dT=-1., dRho_dS=0.) Sl(:) = 0. ; Sr(:) = 0. ; ; SiL(:,:) = 0. ; SiR(:,:) = 0. ppoly_T_l(:,:) = 0.; ppoly_T_r(:,:) = 0. @@ -2391,9 +2389,9 @@ logical function ndiff_unit_tests_discontinuous(verbose) TiL(1,:) = (/ 22.00, 18.00 /); TiL(2,:) = (/ 18.00, 14.00 /); TiL(3,:) = (/ 14.00, 10.00 /); TiR(1,:) = (/ 22.00, 18.00 /); TiR(2,:) = (/ 18.00, 14.00 /); TiR(3,:) = (/ 14.00, 10.00 /); - call mark_unstable_cells( CS, nk, Til, Sil, Pres_l, US, stable_l ) - call mark_unstable_cells( CS, nk, Tir, Sir, Pres_r, US, stable_r ) - call find_neutral_surface_positions_discontinuous(CS, US, nk, Pres_l, hL, TiL, SiL, ppoly_T_l, ppoly_S_l, stable_l, & + call mark_unstable_cells( CS, nk, Til, Sil, Pres_l, stable_l ) + call mark_unstable_cells( CS, nk, Tir, Sir, Pres_r, stable_r ) + call find_neutral_surface_positions_discontinuous(CS, nk, Pres_l, hL, TiL, SiL, ppoly_T_l, ppoly_S_l, stable_l, & Pres_r, hR, TiR, SiR, ppoly_T_r, ppoly_S_r, stable_r, PoL, PoR, KoL, KoR, hEff) ndiff_unit_tests_discontinuous = ndiff_unit_tests_discontinuous .or. test_nsp(v, 12, KoL, KoR, PoL, PoR, hEff, & (/ 1, 1, 1, 1, 2, 2, 2, 2, 3, 3, 3, 3 /), & ! KoL @@ -2405,9 +2403,9 @@ logical function ndiff_unit_tests_discontinuous(verbose) TiL(1,:) = (/ 22.00, 18.00 /); TiL(2,:) = (/ 18.00, 14.00 /); TiL(3,:) = (/ 14.00, 10.00 /); TiR(1,:) = (/ 20.00, 16.00 /); TiR(2,:) = (/ 16.00, 12.00 /); TiR(3,:) = (/ 12.00, 8.00 /); - call mark_unstable_cells( CS, nk, Til, Sil, Pres_l, US, stable_l ) - call mark_unstable_cells( CS, nk, Tir, Sir, Pres_r, US, stable_r ) - call find_neutral_surface_positions_discontinuous(CS, US, nk, Pres_l, hL, TiL, SiL, ppoly_T_l, ppoly_S_l, stable_l, & + call mark_unstable_cells( CS, nk, Til, Sil, Pres_l, stable_l ) + call mark_unstable_cells( CS, nk, Tir, Sir, Pres_r, stable_r ) + call find_neutral_surface_positions_discontinuous(CS, nk, Pres_l, hL, TiL, SiL, ppoly_T_l, ppoly_S_l, stable_l, & Pres_r, hR, TiR, SiR, ppoly_T_r, ppoly_S_r, stable_r, PoL, PoR, KoL, KoR, hEff) ndiff_unit_tests_discontinuous = ndiff_unit_tests_discontinuous .or. test_nsp(v, 12, KoL, KoR, PoL, PoR, hEff, & (/ 1, 1, 1, 2, 2, 2, 2, 3, 3, 3, 3, 3 /), & ! KoL @@ -2419,9 +2417,9 @@ logical function ndiff_unit_tests_discontinuous(verbose) TiL(1,:) = (/ 20.00, 16.00 /); TiL(2,:) = (/ 16.00, 12.00 /); TiL(3,:) = (/ 12.00, 8.00 /); TiR(1,:) = (/ 22.00, 18.00 /); TiR(2,:) = (/ 18.00, 14.00 /); TiR(3,:) = (/ 14.00, 10.00 /); - call mark_unstable_cells( CS, nk, Til, Sil, Pres_l, US, stable_l ) - call mark_unstable_cells( CS, nk, Tir, Sir, Pres_r, US, stable_r ) - call find_neutral_surface_positions_discontinuous(CS, US, nk, Pres_l, hL, TiL, SiL, ppoly_T_l, ppoly_S_l, stable_l, & + call mark_unstable_cells( CS, nk, Til, Sil, Pres_l, stable_l ) + call mark_unstable_cells( CS, nk, Tir, Sir, Pres_r, stable_r ) + call find_neutral_surface_positions_discontinuous(CS, nk, Pres_l, hL, TiL, SiL, ppoly_T_l, ppoly_S_l, stable_l, & Pres_r, hR, TiR, SiR, ppoly_T_r, ppoly_S_r, stable_r, PoL, PoR, KoL, KoR, hEff) ndiff_unit_tests_discontinuous = ndiff_unit_tests_discontinuous .or. test_nsp(v, 12, KoL, KoR, PoL, PoR, hEff, & (/ 1, 1, 1, 1, 1, 2, 2, 2, 2, 3, 3, 3 /), & ! KoL @@ -2433,9 +2431,9 @@ logical function ndiff_unit_tests_discontinuous(verbose) TiL(1,:) = (/ 22.00, 20.00 /); TiL(2,:) = (/ 18.00, 16.00 /); TiL(3,:) = (/ 14.00, 12.00 /); TiR(1,:) = (/ 32.00, 24.00 /); TiR(2,:) = (/ 22.00, 14.00 /); TiR(3,:) = (/ 12.00, 4.00 /); - call mark_unstable_cells( CS, nk, Til, Sil, Pres_l, US, stable_l ) - call mark_unstable_cells( CS, nk, Tir, Sir, Pres_r, US, stable_r ) - call find_neutral_surface_positions_discontinuous(CS, US, nk, Pres_l, hL, TiL, SiL, ppoly_T_l, ppoly_S_l, stable_l, & + call mark_unstable_cells( CS, nk, Til, Sil, Pres_l, stable_l ) + call mark_unstable_cells( CS, nk, Tir, Sir, Pres_r, stable_r ) + call find_neutral_surface_positions_discontinuous(CS, nk, Pres_l, hL, TiL, SiL, ppoly_T_l, ppoly_S_l, stable_l, & Pres_r, hR, TiR, SiR, ppoly_T_r, ppoly_S_r, stable_r, PoL, PoR, KoL, KoR, hEff) ndiff_unit_tests_discontinuous = ndiff_unit_tests_discontinuous .or. test_nsp(v, 12, KoL, KoR, PoL, PoR, hEff, & (/ 1, 1, 1, 1, 1, 2, 2, 3, 3, 3, 3, 3 /), & ! KoL @@ -2447,9 +2445,9 @@ logical function ndiff_unit_tests_discontinuous(verbose) TiL(1,:) = (/ 22.00, 18.00 /); TiL(2,:) = (/ 18.00, 14.00 /); TiL(3,:) = (/ 14.00, 10.00 /); TiR(1,:) = (/ 14.00, 14.00 /); TiR(2,:) = (/ 14.00, 14.00 /); TiR(3,:) = (/ 12.00, 8.00 /); - call mark_unstable_cells( CS, nk, Til, Sil, Pres_l, US, stable_l ) - call mark_unstable_cells( CS, nk, Tir, Sir, Pres_r, US, stable_r ) - call find_neutral_surface_positions_discontinuous(CS, US, nk, Pres_l, hL, TiL, SiL, ppoly_T_l, ppoly_S_l, stable_l, & + call mark_unstable_cells( CS, nk, Til, Sil, Pres_l, stable_l ) + call mark_unstable_cells( CS, nk, Tir, Sir, Pres_r, stable_r ) + call find_neutral_surface_positions_discontinuous(CS, nk, Pres_l, hL, TiL, SiL, ppoly_T_l, ppoly_S_l, stable_l, & Pres_r, hR, TiR, SiR, ppoly_T_r, ppoly_S_r, stable_r, PoL, PoR, KoL, KoR, hEff) ndiff_unit_tests_discontinuous = ndiff_unit_tests_discontinuous .or. test_nsp(v, 12, KoL, KoR, PoL, PoR, hEff, & (/ 1, 1, 1, 1, 1, 1, 2, 2, 3, 3, 3, 3 /), & ! KoL @@ -2461,9 +2459,9 @@ logical function ndiff_unit_tests_discontinuous(verbose) TiL(1,:) = (/ 14.00, 14.00 /); TiL(2,:) = (/ 14.00, 12.00 /); TiL(3,:) = (/ 10.00, 8.00 /); TiR(1,:) = (/ 14.00, 14.00 /); TiR(2,:) = (/ 14.00, 14.00 /); TiR(3,:) = (/ 14.00, 14.00 /); - call mark_unstable_cells( CS, nk, Til, Sil, Pres_l, US, stable_l ) - call mark_unstable_cells( CS, nk, Tir, Sir, Pres_r, US, stable_r ) - call find_neutral_surface_positions_discontinuous(CS, US, nk, Pres_l, hL, TiL, SiL, ppoly_T_l, ppoly_S_l, stable_l, & + call mark_unstable_cells( CS, nk, Til, Sil, Pres_l, stable_l ) + call mark_unstable_cells( CS, nk, Tir, Sir, Pres_r, stable_r ) + call find_neutral_surface_positions_discontinuous(CS, nk, Pres_l, hL, TiL, SiL, ppoly_T_l, ppoly_S_l, stable_l, & Pres_r, hR, TiR, SiR, ppoly_T_r, ppoly_S_r, stable_r, PoL, PoR, KoL, KoR, hEff) ndiff_unit_tests_discontinuous = ndiff_unit_tests_discontinuous .or. test_nsp(v, 12, KoL, KoR, PoL, PoR, hEff, & (/ 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 3 /), & ! KoL @@ -2475,9 +2473,9 @@ logical function ndiff_unit_tests_discontinuous(verbose) TiL(1,:) = (/ 14.00, 14.00 /); TiL(2,:) = (/ 14.00, 12.00 /); TiL(3,:) = (/ 10.00, 8.00 /); TiR(1,:) = (/ 14.00, 14.00 /); TiR(2,:) = (/ 14.00, 14.00 /); TiR(3,:) = (/ 12.00, 4.00 /); - call mark_unstable_cells( CS, nk, Til, Sil, Pres_l, US, stable_l ) - call mark_unstable_cells( CS, nk, Tir, Sir, Pres_r, US, stable_r ) - call find_neutral_surface_positions_discontinuous(CS, US, nk, Pres_l, hL, TiL, SiL, ppoly_T_l, ppoly_S_l, stable_l, & + call mark_unstable_cells( CS, nk, Til, Sil, Pres_l, stable_l ) + call mark_unstable_cells( CS, nk, Tir, Sir, Pres_r, stable_r ) + call find_neutral_surface_positions_discontinuous(CS, nk, Pres_l, hL, TiL, SiL, ppoly_T_l, ppoly_S_l, stable_l, & Pres_r, hR, TiR, SiR, ppoly_T_r, ppoly_S_r, stable_r, PoL, PoR, KoL, KoR, hEff) ndiff_unit_tests_discontinuous = ndiff_unit_tests_discontinuous .or. test_nsp(v, 12, KoL, KoR, PoL, PoR, hEff, & (/ 1, 1, 1, 1, 1, 1, 2, 2, 2, 3, 3, 3 /), & ! KoL @@ -2489,9 +2487,9 @@ logical function ndiff_unit_tests_discontinuous(verbose) TiL(1,:) = (/ 14.00, 14.00 /); TiL(2,:) = (/ 14.00, 10.00 /); TiL(3,:) = (/ 10.00, 2.00 /); TiR(1,:) = (/ 14.00, 14.00 /); TiR(2,:) = (/ 14.00, 10.00 /); TiR(3,:) = (/ 10.00, 2.00 /); - call mark_unstable_cells( CS, nk, Til, Sil, Pres_l, US, stable_l ) - call mark_unstable_cells( CS, nk, Tir, Sir, Pres_r, US, stable_r ) - call find_neutral_surface_positions_discontinuous(CS, US, nk, Pres_l, hL, TiL, SiL, ppoly_T_l, ppoly_S_l, stable_l, & + call mark_unstable_cells( CS, nk, Til, Sil, Pres_l, stable_l ) + call mark_unstable_cells( CS, nk, Tir, Sir, Pres_r, stable_r ) + call find_neutral_surface_positions_discontinuous(CS, nk, Pres_l, hL, TiL, SiL, ppoly_T_l, ppoly_S_l, stable_l, & Pres_r, hR, TiR, SiR, ppoly_T_r, ppoly_S_r, stable_r, PoL, PoR, KoL, KoR, hEff) ndiff_unit_tests_discontinuous = ndiff_unit_tests_discontinuous .or. test_nsp(v, 12, KoL, KoR, PoL, PoR, hEff, & (/ 1, 1, 1, 1, 2, 2, 2, 2, 3, 3, 3, 3 /), & ! KoL @@ -2503,9 +2501,9 @@ logical function ndiff_unit_tests_discontinuous(verbose) TiL(1,:) = (/ 14.00, 12.00 /); TiL(2,:) = (/ 10.00, 10.00 /); TiL(3,:) = (/ 8.00, 2.00 /); TiR(1,:) = (/ 14.00, 12.00 /); TiR(2,:) = (/ 12.00, 8.00 /); TiR(3,:) = (/ 8.00, 2.00 /); - call mark_unstable_cells( CS, nk, Til, Sil, Pres_l, US, stable_l ) - call mark_unstable_cells( CS, nk, Tir, Sir, Pres_r, US, stable_r ) - call find_neutral_surface_positions_discontinuous(CS, US, nk, Pres_l, hL, TiL, SiL, ppoly_T_l, ppoly_S_l, stable_l, & + call mark_unstable_cells( CS, nk, Til, Sil, Pres_l, stable_l ) + call mark_unstable_cells( CS, nk, Tir, Sir, Pres_r, stable_r ) + call find_neutral_surface_positions_discontinuous(CS, nk, Pres_l, hL, TiL, SiL, ppoly_T_l, ppoly_S_l, stable_l, & Pres_r, hR, TiR, SiR, ppoly_T_r, ppoly_S_r, stable_r, PoL, PoR, KoL, KoR, hEff) ndiff_unit_tests_discontinuous = ndiff_unit_tests_discontinuous .or. test_nsp(v, 12, KoL, KoR, PoL, PoR, hEff, & (/ 1, 1, 1, 1, 2, 2, 3, 3, 3, 3, 3, 3 /), & ! KoL @@ -2517,9 +2515,9 @@ logical function ndiff_unit_tests_discontinuous(verbose) TiL(1,:) = (/ 12.00, 12.00 /); TiL(2,:) = (/ 12.00, 10.00 /); TiL(3,:) = (/ 10.00, 6.00 /); TiR(1,:) = (/ 12.00, 10.00 /); TiR(2,:) = (/ 10.00, 12.00 /); TiR(3,:) = (/ 8.00, 4.00 /); - call mark_unstable_cells( CS, nk, Til, Sil, Pres_l, US, stable_l ) - call mark_unstable_cells( CS, nk, Tir, Sir, Pres_r, US, stable_r ) - call find_neutral_surface_positions_discontinuous(CS, US, nk, Pres_l, hL, TiL, SiL, ppoly_T_l, ppoly_S_l, stable_l, & + call mark_unstable_cells( CS, nk, Til, Sil, Pres_l, stable_l ) + call mark_unstable_cells( CS, nk, Tir, Sir, Pres_r, stable_r ) + call find_neutral_surface_positions_discontinuous(CS, nk, Pres_l, hL, TiL, SiL, ppoly_T_l, ppoly_S_l, stable_l, & Pres_r, hR, TiR, SiR, ppoly_T_r, ppoly_S_r, stable_r, PoL, PoR, KoL, KoR, hEff) ndiff_unit_tests_discontinuous = ndiff_unit_tests_discontinuous .or. test_nsp(v, 12, KoL, KoR, PoL, PoR, hEff, & (/ 1, 1, 2, 2, 2, 3, 3, 3, 3, 3, 3, 3 /), & ! KoL @@ -2531,9 +2529,9 @@ logical function ndiff_unit_tests_discontinuous(verbose) TiL(1,:) = (/ 14.00, 14.00 /); TiL(2,:) = (/ 10.00, 10.00 /); TiL(3,:) = (/ 8.00, 6.00 /); TiR(1,:) = (/ 10.00, 14.00 /); TiR(2,:) = (/ 16.00, 16.00 /); TiR(3,:) = (/ 12.00, 4.00 /); - call mark_unstable_cells( CS, nk, Til, Sil, Pres_l, US, stable_l ) - call mark_unstable_cells( CS, nk, Tir, Sir, Pres_r, US, stable_r ) - call find_neutral_surface_positions_discontinuous(CS, US, nk, Pres_l, hL, TiL, SiL, ppoly_T_l, ppoly_S_l, stable_l, & + call mark_unstable_cells( CS, nk, Til, Sil, Pres_l, stable_l ) + call mark_unstable_cells( CS, nk, Tir, Sir, Pres_r, stable_r ) + call find_neutral_surface_positions_discontinuous(CS, nk, Pres_l, hL, TiL, SiL, ppoly_T_l, ppoly_S_l, stable_l, & Pres_r, hR, TiR, SiR, ppoly_T_r, ppoly_S_r, stable_r, PoL, PoR, KoL, KoR, hEff) ndiff_unit_tests_discontinuous = ndiff_unit_tests_discontinuous .or. test_nsp(v, 12, KoL, KoR, PoL, PoR, hEff, & (/ 1, 1, 2, 2, 2, 2, 2, 2, 3, 3, 3, 3 /), & ! KoL @@ -2545,9 +2543,9 @@ logical function ndiff_unit_tests_discontinuous(verbose) TiL(1,:) = (/ 8.00, 12.00 /); TiL(2,:) = (/ 12.00, 10.00 /); TiL(3,:) = (/ 8.00, 4.00 /); TiR(1,:) = (/ 10.00, 14.00 /); TiR(2,:) = (/ 14.00, 12.00 /); TiR(3,:) = (/ 10.00, 6.00 /); - call mark_unstable_cells( CS, nk, Til, Sil, Pres_l, US, stable_l ) - call mark_unstable_cells( CS, nk, Tir, Sir, Pres_r, US, stable_r ) - call find_neutral_surface_positions_discontinuous(CS, US, nk, Pres_l, hL, TiL, SiL, ppoly_T_l, ppoly_S_l, stable_l, & + call mark_unstable_cells( CS, nk, Til, Sil, Pres_l, stable_l ) + call mark_unstable_cells( CS, nk, Tir, Sir, Pres_r, stable_r ) + call find_neutral_surface_positions_discontinuous(CS, nk, Pres_l, hL, TiL, SiL, ppoly_T_l, ppoly_S_l, stable_l, & Pres_r, hR, TiR, SiR, ppoly_T_r, ppoly_S_r, stable_r, PoL, PoR, KoL, KoR, hEff) ndiff_unit_tests_discontinuous = ndiff_unit_tests_discontinuous .or. test_nsp(v, 12, KoL, KoR, PoL, PoR, hEff, & (/ 1, 1, 1, 1, 2, 2, 2, 2, 3, 3, 3, 3 /), & ! KoL @@ -2590,8 +2588,6 @@ logical function ndiff_unit_tests_discontinuous(verbose) (/12.,0./), (/34.,2./)), "Salt stratified Linearized Alpha/Beta")) if (.not. ndiff_unit_tests_discontinuous) write(stdout,*) 'Pass' - deallocate(US) - end function ndiff_unit_tests_discontinuous !> Returns true if a test of fv_diff() fails, and conditionally writes results to stream From 8a1e9b502bf079d1f24a2ade3023d55fa4db9534 Mon Sep 17 00:00:00 2001 From: Matthew Harrison Date: Tue, 21 Apr 2020 10:39:48 -0400 Subject: [PATCH 221/316] New option TEMP_SALT_INIT_VERTICAL_REMAP_ONLY - This commit makes available an option to initialize the model temperature and salinity from a data set which is co-located with the model horizontal grid, but for which horizontal extrapolation and vertical remapping are needed. --- src/framework/MOM_horizontal_regridding.F90 | 79 ++++++++++--------- .../MOM_state_initialization.F90 | 9 ++- 2 files changed, 49 insertions(+), 39 deletions(-) diff --git a/src/framework/MOM_horizontal_regridding.F90 b/src/framework/MOM_horizontal_regridding.F90 index 7c19d715db..ebbaf3e3b4 100644 --- a/src/framework/MOM_horizontal_regridding.F90 +++ b/src/framework/MOM_horizontal_regridding.F90 @@ -272,7 +272,7 @@ end subroutine fill_miss_2d !> Extrapolate and interpolate from a file record subroutine horiz_interp_and_extrap_tracer_record(filename, varnam, conversion, recnum, G, tr_z, & mask_z, z_in, z_edges_in, missing_value, reentrant_x, & - tripolar_n, homogenize, m_to_Z, answers_2018) + tripolar_n, homogenize, m_to_Z, answers_2018, ongrid) character(len=*), intent(in) :: filename !< Path to file containing tracer to be !! interpolated. @@ -296,6 +296,9 @@ subroutine horiz_interp_and_extrap_tracer_record(filename, varnam, conversion, logical, optional, intent(in) :: answers_2018 !< If true, use expressions that give the same !! answers as the code did in late 2018. Otherwise !! add parentheses for rotational symmetry. + logical, optional, intent(in) :: ongrid !< If true, then data are assumed to have been interpolated + !! to the model horizontal grid. In this case, only + !! extrapolation is performed by this routine ! Local variables real, dimension(:,:), allocatable :: tr_in, tr_inp ! A 2-d array for holding input data on @@ -314,6 +317,7 @@ subroutine horiz_interp_and_extrap_tracer_record(filename, varnam, conversion, real :: roundoff ! The magnitude of roundoff, usually ~2e-16. real :: add_offset, scale_factor logical :: add_np + logical :: is_ongrid character(len=8) :: laynum type(horiz_interp_type) :: Interp integer :: is, ie, js, je ! compute domain indices @@ -336,6 +340,8 @@ subroutine horiz_interp_and_extrap_tracer_record(filename, varnam, conversion, id_clock_read = cpu_clock_id('(Initialize tracer from Z) read', grain=CLOCK_LOOP) + is_ongrid=.false. + if (present(ongrid)) is_ongrid=ongrid if (allocated(tr_z)) deallocate(tr_z) if (allocated(mask_z)) deallocate(mask_z) @@ -418,41 +424,38 @@ subroutine horiz_interp_and_extrap_tracer_record(filename, varnam, conversion, if (present(m_to_Z)) then ; do k=1,kd ; z_in(k) = m_to_Z * z_in(k) ; enddo ; endif ! extrapolate the input data to the north pole using the northerm-most latitude - - max_lat = maxval(lat_in) add_np=.false. - if (max_lat < 90.0) then - add_np=.true. - jdp=jd+1 - allocate(lat_inp(jdp)) - lat_inp(1:jd)=lat_in(:) - lat_inp(jd+1)=90.0 - deallocate(lat_in) - allocate(lat_in(1:jdp)) - lat_in(:)=lat_inp(:) - else - jdp=jd + jdp=jd + if (.not. is_ongrid) then + max_lat = maxval(lat_in) + if (max_lat < 90.0) then + add_np=.true. + jdp=jd+1 + allocate(lat_inp(jdp)) + lat_inp(1:jd)=lat_in(:) + lat_inp(jd+1)=90.0 + deallocate(lat_in) + allocate(lat_in(1:jdp)) + lat_in(:)=lat_inp(:) + endif endif - ! construct level cell boundaries as the mid-point between adjacent centers z_edges_in(1) = 0.0 do K=2,kd - z_edges_in(K)=0.5*(z_in(k-1)+z_in(k)) + z_edges_in(K)=0.5*(z_in(k-1)+z_in(k)) enddo z_edges_in(kd+1)=2.0*z_in(kd) - z_in(kd-1) - call horiz_interp_init() - - lon_in = lon_in*PI_180 - lat_in = lat_in*PI_180 - allocate(x_in(id,jdp),y_in(id,jdp)) - call meshgrid(lon_in,lat_in, x_in, y_in) - - lon_out(:,:) = G%geoLonT(:,:)*PI_180 - lat_out(:,:) = G%geoLatT(:,:)*PI_180 - - + if (.not. is_ongrid) then + call horiz_interp_init() + lon_in = lon_in*PI_180 + lat_in = lat_in*PI_180 + allocate(x_in(id,jdp),y_in(id,jdp)) + call meshgrid(lon_in,lat_in, x_in, y_in) + lon_out(:,:) = G%geoLonT(:,:)*PI_180 + lat_out(:,:) = G%geoLatT(:,:)*PI_180 + endif allocate(tr_in(id,jd)) ; tr_in(:,:)=0.0 allocate(tr_inp(id,jdp)) ; tr_inp(:,:)=0.0 allocate(mask_in(id,jdp)) ; mask_in(:,:)=0.0 @@ -462,7 +465,6 @@ subroutine horiz_interp_and_extrap_tracer_record(filename, varnam, conversion, call mpp_max(max_depth) if (z_edges_in(kd+1) Date: Tue, 21 Apr 2020 11:34:37 -0400 Subject: [PATCH 222/316] Improve performance of TS ongrid initialization - local distributed read from disk in the case of ongrid initialization rather than broadcasting the entire horizontal slice --- src/framework/MOM_horizontal_regridding.F90 | 114 ++++++++++++-------- 1 file changed, 71 insertions(+), 43 deletions(-) diff --git a/src/framework/MOM_horizontal_regridding.F90 b/src/framework/MOM_horizontal_regridding.F90 index e94349ceb2..66f58b5b9d 100644 --- a/src/framework/MOM_horizontal_regridding.F90 +++ b/src/framework/MOM_horizontal_regridding.F90 @@ -448,7 +448,10 @@ subroutine horiz_interp_and_extrap_tracer_record(filename, varnam, conversion, enddo z_edges_in(kd+1)=2.0*z_in(kd) - z_in(kd-1) - if (.not. is_ongrid) then + if (is_ongrid) then + allocate(tr_in(is:ie,js:je)) ; tr_in(:,:)=0.0 + allocate(mask_in(is:ie,js:je)) ; mask_in(:,:)=0.0 + else call horiz_interp_init() lon_in = lon_in*PI_180 lat_in = lat_in*PI_180 @@ -456,11 +459,13 @@ subroutine horiz_interp_and_extrap_tracer_record(filename, varnam, conversion, call meshgrid(lon_in,lat_in, x_in, y_in) lon_out(:,:) = G%geoLonT(:,:)*PI_180 lat_out(:,:) = G%geoLatT(:,:)*PI_180 + allocate(tr_in(id,jd)) ; tr_in(:,:)=0.0 + allocate(tr_inp(id,jdp)) ; tr_inp(:,:)=0.0 + allocate(mask_in(id,jdp)) ; mask_in(:,:)=0.0 + allocate(last_row(id)) ; last_row(:)=0.0 endif - allocate(tr_in(id,jd)) ; tr_in(:,:)=0.0 - allocate(tr_inp(id,jdp)) ; tr_inp(:,:)=0.0 - allocate(mask_in(id,jdp)) ; mask_in(:,:)=0.0 - allocate(last_row(id)) ; last_row(:)=0.0 + + max_depth = maxval(G%bathyT) call mpp_max(max_depth) @@ -473,50 +478,72 @@ subroutine horiz_interp_and_extrap_tracer_record(filename, varnam, conversion, ! to define the layers do k=1,kd write(laynum,'(I8)') k ; laynum = adjustl(laynum) + mask_in=0.0 + if (is_ongrid) then + start(1) = is+G%HI%idg_offset ; start(2) = js+G%HI%jdg_offset ; start(3) = k + count(1) = ie-is+1 ; count(2) = je-js+1; count(3) = 1 + rcode = NF90_GET_VAR(ncid,varid, tr_in, start, count) + 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)) + + do j=js,je + do i=is,ie + if (abs(tr_in(i,j)-missing_value) > abs(roundoff*missing_value)) then + mask_in(i,j) = 1.0 + tr_in(i,j) = (tr_in(i,j)*scale_factor+add_offset) * conversion + else + tr_in(i,j) = missing_value + endif + enddo + enddo - 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 /= 0) call MOM_error(FATAL,"hinterp_and_extract_from_Fie: "//& - "error reading level "//trim(laynum)//" of variable "//& - trim(varnam)//" in file "// trim(filename)) + else + 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 /= 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) > abs(roundoff*missing_value)) then + pole = pole+last_row(i) + npole = npole+1.0 + endif + enddo + if (npole > 0) then + pole=pole/npole + else + pole=missing_value + endif + tr_inp(:,1:jd) = tr_in(:,:) + tr_inp(:,jdp) = pole + else + tr_inp(:,:) = tr_in(:,:) + endif + endif - if (add_np) then - last_row(:)=tr_in(:,jd); pole=0.0;npole=0.0 + call mpp_sync() + call mpp_broadcast(tr_inp, id*jdp, root_PE()) + call mpp_sync_self() + + do j=1,jdp do i=1,id - if (abs(tr_in(i,jd)-missing_value) > abs(roundoff*missing_value)) then - pole = pole+last_row(i) - npole = npole+1.0 - endif + if (abs(tr_inp(i,j)-missing_value) > abs(roundoff*missing_value)) then + mask_in(i,j) = 1.0 + tr_inp(i,j) = (tr_inp(i,j)*scale_factor+add_offset) * conversion + else + tr_inp(i,j) = missing_value + endif enddo - if (npole > 0) then - pole=pole/npole - else - pole=missing_value - endif - tr_inp(:,1:jd) = tr_in(:,:) - tr_inp(:,jdp) = pole - else - tr_inp(:,:) = tr_in(:,:) - endif - endif + enddo - call mpp_sync() - call mpp_broadcast(tr_inp, id*jdp, root_PE()) - call mpp_sync_self() + endif - mask_in=0.0 - do j=1,jdp - do i=1,id - if (abs(tr_inp(i,j)-missing_value) > abs(roundoff*missing_value)) then - mask_in(i,j) = 1.0 - tr_inp(i,j) = (tr_inp(i,j)*scale_factor+add_offset) * conversion - else - tr_inp(i,j) = missing_value - endif - enddo - enddo ! call fms routine horiz_interp to interpolate input level data to model horizontal grid if (.not. is_ongrid) then @@ -529,9 +556,10 @@ subroutine horiz_interp_and_extrap_tracer_record(filename, varnam, conversion, call myStats(tr_inp,missing_value, is,ie,js,je,k,'Tracer from file') endif endif + tr_out(:,:) = 0.0 if (is_ongrid) then - tr_out(is:ie,js:je)=tr_inp(is+G%HI%idg_offset:ie+G%HI%idg_offset,js+G%HI%jdg_offset:je+G%HI%jdg_offset) + tr_out(is:ie,js:je)=tr_in(is:ie,js:je) else call horiz_interp(Interp,tr_inp,tr_out(is:ie,js:je), missing_value=missing_value, new_missing_handle=.true.) endif From 3fb86e3ed4f7bf1eae44a1c6bb2564ad65c8ad66 Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Tue, 21 Apr 2020 12:18:34 -0600 Subject: [PATCH 223/316] Avoid division by zero This PR add two hard-coded parameters (AH_min and KH_min) to avoid dividing by zero when computing the Biharmonic and Laplacian grid Reynolds numbers, respectively. It also fixed the size of an array used in the Biharmonic Re calculation. --- src/parameterizations/lateral/MOM_hor_visc.F90 | 11 ++++++++--- 1 file changed, 8 insertions(+), 3 deletions(-) diff --git a/src/parameterizations/lateral/MOM_hor_visc.F90 b/src/parameterizations/lateral/MOM_hor_visc.F90 index e18b626c37..de00aa4a96 100644 --- a/src/parameterizations/lateral/MOM_hor_visc.F90 +++ b/src/parameterizations/lateral/MOM_hor_visc.F90 @@ -348,6 +348,11 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, ! calculation gives the same value as if f were 0 [nondim]. real :: H0_GME ! Depth used to scale down GME coefficient in shallow areas [Z ~> m] real :: KE ! Local kinetic energy [L2 T-2 ~> m2 s-2] + real, parameter :: KH_min = 1.E-30 ! This is the minimun horizontal Laplacian viscosity used to estimate the + ! grid Raynolds number [L2 T-1 ~> m2 s-1] + real, parameter :: AH_min = 1.E-30 ! This is the minimun horizontal Biharmonic viscosity used to estimate the + ! grid Raynolds number [L4 T-1 ~> m4 s-1] + logical :: rescale_Kh, legacy_bound logical :: find_FrictWork logical :: apply_OBC = .false. @@ -849,7 +854,7 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, if (CS%id_grid_Re_Kh>0) then KE = 0.125*((u(I,j,k)+u(I-1,j,k))**2 + (v(i,J,k)+v(i,J-1,k))**2) - grid_Re_Kh(i,j,k) = (sqrt(KE) * sqrt(CS%grid_sp_h2(i,j)))/Kh + grid_Re_Kh(i,j,k) = (sqrt(KE) * sqrt(CS%grid_sp_h2(i,j)))/MAX(Kh,KH_min) endif if (CS%id_div_xx_h>0) div_xx_h(i,j,k) = div_xx(i,j) @@ -902,7 +907,7 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, if (CS%id_grid_Re_Ah>0) then KE = 0.125*((u(I,j,k)+u(I-1,j,k))**2 + (v(i,J,k)+v(i,J-1,k))**2) - grid_Re_Ah(i,j,k) = (sqrt(KE) * CS%grid_sp_h3(i,j))/Ah + grid_Re_Ah(i,j,k) = (sqrt(KE) * CS%grid_sp_h3(i,j))/MAX(Ah,AH_min) endif str_xx(i,j) = str_xx(i,j) + Ah * & @@ -1728,7 +1733,7 @@ subroutine hor_visc_init(Time, G, US, param_file, diag, CS, MEKE) ALLOC_(CS%Idxdy2v(isd:ied,JsdB:JedB)) ; CS%Idxdy2v(:,:) = 0.0 ALLOC_(CS%Ah_bg_xx(isd:ied,jsd:jed)) ; CS%Ah_bg_xx(:,:) = 0.0 ALLOC_(CS%Ah_bg_xy(IsdB:IedB,JsdB:JedB)) ; CS%Ah_bg_xy(:,:) = 0.0 - ALLOC_(CS%grid_sp_h3(IsdB:IedB,JsdB:JedB)); CS%grid_sp_h3(:,:) = 0.0 + ALLOC_(CS%grid_sp_h3(isd:ied,jsd:jed)) ; CS%grid_sp_h3(:,:) = 0.0 if (CS%bound_Ah .or. CS%better_bound_Ah) then ALLOC_(CS%Ah_Max_xx(isd:ied,jsd:jed)) ; CS%Ah_Max_xx(:,:) = 0.0 ALLOC_(CS%Ah_Max_xy(IsdB:IedB,JsdB:JedB)) ; CS%Ah_Max_xy(:,:) = 0.0 From e955c6d9ad0f9f1b6cc6555b5443a0ce0a49c60a Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Tue, 21 Apr 2020 14:13:44 -0600 Subject: [PATCH 224/316] Fix openmp directives --- src/parameterizations/lateral/MOM_hor_visc.F90 | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/parameterizations/lateral/MOM_hor_visc.F90 b/src/parameterizations/lateral/MOM_hor_visc.F90 index de00aa4a96..19e0586bfd 100644 --- a/src/parameterizations/lateral/MOM_hor_visc.F90 +++ b/src/parameterizations/lateral/MOM_hor_visc.F90 @@ -478,12 +478,12 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, !$OMP is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz, & !$OMP apply_OBC, rescale_Kh, legacy_bound, find_FrictWork, & !$OMP use_MEKE_Ku, use_MEKE_Au, boundary_mask_h, boundary_mask_q, & - !$OMP backscat_subround, GME_coeff_limiter, & + !$OMP backscat_subround, GME_coeff_limiter, KH_min, AH_min, & !$OMP h_neglect, h_neglect3, FWfrac, inv_PI3, inv_PI5, H0_GME, & !$OMP diffu, diffv, max_diss_rate_h, max_diss_rate_q, & !$OMP Kh_h, Kh_q, Ah_h, Ah_q, FrictWork, FrictWork_GME, & !$OMP div_xx_h, vort_xy_q, GME_coeff_h, GME_coeff_q, & - !$OMP TD, KH_u_GME, KH_v_GME & + !$OMP TD, KH_u_GME, KH_v_GME, grid_Re_Kh, grid_Re_Ah, & !$OMP ) & !$OMP private( & !$OMP i, j, k, n, & @@ -497,7 +497,7 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, !$OMP grad_vel_mag_bt_h, grad_vel_mag_bt_q, grad_d2vel_mag_h, & !$OMP meke_res_fn, Shear_mag, vert_vort_mag, hrat_min, visc_bound_rem, & !$OMP Kh, Ah, AhSm, AhLth, local_strain, Sh_F_pow, & - !$OMP dDel2vdx, dDel2udy, & + !$OMP dDel2vdx, dDel2udy, KE, & !$OMP h2uq, h2vq, hu, hv, hq, FatH, RoScl, GME_coeff & !$OMP ) do k=1,nz From e3cbcbbd0dd2a213c8bf15f6a0067591772034ae Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Tue, 21 Apr 2020 14:13:44 -0600 Subject: [PATCH 225/316] Fix openmp directives --- src/parameterizations/lateral/MOM_hor_visc.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/parameterizations/lateral/MOM_hor_visc.F90 b/src/parameterizations/lateral/MOM_hor_visc.F90 index de00aa4a96..7f5e63394f 100644 --- a/src/parameterizations/lateral/MOM_hor_visc.F90 +++ b/src/parameterizations/lateral/MOM_hor_visc.F90 @@ -483,7 +483,7 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, !$OMP diffu, diffv, max_diss_rate_h, max_diss_rate_q, & !$OMP Kh_h, Kh_q, Ah_h, Ah_q, FrictWork, FrictWork_GME, & !$OMP div_xx_h, vort_xy_q, GME_coeff_h, GME_coeff_q, & - !$OMP TD, KH_u_GME, KH_v_GME & + !$OMP TD, KH_u_GME, KH_v_GME, grid_Re_Kh, grid_Re_Ah & !$OMP ) & !$OMP private( & !$OMP i, j, k, n, & @@ -497,7 +497,7 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, !$OMP grad_vel_mag_bt_h, grad_vel_mag_bt_q, grad_d2vel_mag_h, & !$OMP meke_res_fn, Shear_mag, vert_vort_mag, hrat_min, visc_bound_rem, & !$OMP Kh, Ah, AhSm, AhLth, local_strain, Sh_F_pow, & - !$OMP dDel2vdx, dDel2udy, & + !$OMP dDel2vdx, dDel2udy, KE, & !$OMP h2uq, h2vq, hu, hv, hq, FatH, RoScl, GME_coeff & !$OMP ) do k=1,nz From dc6937259d1970e8ca1d91adcff77a4a16786150 Mon Sep 17 00:00:00 2001 From: Matthew Harrison Date: Tue, 21 Apr 2020 22:27:55 -0400 Subject: [PATCH 226/316] Fix parameter description for TEMP_SALT_INIT_VERTICAL_REMAP_ONLY --- src/initialization/MOM_state_initialization.F90 | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/src/initialization/MOM_state_initialization.F90 b/src/initialization/MOM_state_initialization.F90 index 4b290a2350..beeaf6e46a 100644 --- a/src/initialization/MOM_state_initialization.F90 +++ b/src/initialization/MOM_state_initialization.F90 @@ -2117,7 +2117,9 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, G, GV, US, PF, just_read_param "This sets the default value for the various _2018_ANSWERS parameters.", & default=.true.) call get_param(PF, mdl, "TEMP_SALT_INIT_VERTICAL_REMAP_ONLY", pre_gridded, & - "This sets the default value for the various _2018_ANSWERS parameters.", & + "If true, initial conditions are on the model horizontal grid. " //& + "Extrapolation over missing ocean values is done using an ICE-9 "//& + "procedure with vertical ALE remapping .", & default=.false.) if (useALEremapping) then call get_param(PF, mdl, "REMAPPING_2018_ANSWERS", answers_2018, & From 1e7fa519b1004af16ab8cf417a0b4ef650899f74 Mon Sep 17 00:00:00 2001 From: alperaltuntas Date: Tue, 21 Apr 2020 21:41:37 -0600 Subject: [PATCH 227/316] add KPP timing clocks and omp directives --- .../vertical/MOM_CVMix_KPP.F90 | 31 +++++++++++++++++-- 1 file changed, 29 insertions(+), 2 deletions(-) diff --git a/src/parameterizations/vertical/MOM_CVMix_KPP.F90 b/src/parameterizations/vertical/MOM_CVMix_KPP.F90 index 8151511bbf..b17d91ff8d 100644 --- a/src/parameterizations/vertical/MOM_CVMix_KPP.F90 +++ b/src/parameterizations/vertical/MOM_CVMix_KPP.F90 @@ -16,6 +16,8 @@ module MOM_CVMix_KPP use MOM_verticalGrid, only : verticalGrid_type use MOM_wave_interface, only : wave_parameters_CS, Get_Langmuir_Number use MOM_domains, only : pass_var +use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end +use MOM_cpu_clock, only : CLOCK_MODULE, CLOCK_ROUTINE use CVMix_kpp, only : CVMix_init_kpp, CVMix_put_kpp, CVMix_get_kpp_real use CVMix_kpp, only : CVMix_coeffs_kpp @@ -168,6 +170,10 @@ module MOM_CVMix_KPP end type KPP_CS +!>@{ CPU time clocks +integer :: id_clock_KPP_calc, id_clock_KPP_compute_BLD, id_clock_KPP_smoothing +!!@} + #define __DO_SAFETY_CHECKS__ contains @@ -225,9 +231,9 @@ logical function KPP_init(paramFile, G, GV, US, diag, Time, CS, passive, Waves) 'The number of times the 1-1-4-1-1 Laplacian filter is applied on '// & 'OBL depth.', & default=0) - if ((CS%n_smooth > G%domain%nihalo) then + if (CS%n_smooth > G%domain%nihalo) then call MOM_error(FATAL,'KPP smoothing number (N_SMOOTH) cannot be greater than NIHALO.') - elseif ((CS%n_smooth > G%domain%njhalo) then + elseif (CS%n_smooth > G%domain%njhalo) then call MOM_error(FATAL,'KPP smoothing number (N_SMOOTH) cannot be greater than NJHALO.') endif if (CS%n_smooth > 0) then @@ -235,6 +241,7 @@ logical function KPP_init(paramFile, G, GV, US, diag, Time, CS, passive, Waves) 'If true, apply OBLdepth smoothing at a cell only if the OBLdepth '// & 'gets deeper via smoothing.', & default=.false.) + id_clock_KPP_smoothing = cpu_clock_id('Ocean KPP BLD smoothing)', grain=CLOCK_ROUTINE) endif call get_param(paramFile, mdl, 'RI_CRIT', CS%Ri_crit, & 'Critical bulk Richardson number used to define depth of the '// & @@ -582,6 +589,8 @@ logical function KPP_init(paramFile, G, GV, US, diag, Time, CS, passive, Waves) if (CS%id_EnhK > 0) allocate( CS%EnhK( SZI_(G), SZJ_(G), SZK_(G)+1 ) ) if (CS%id_EnhK > 0) CS%EnhK(:,:,:) = 0. + id_clock_KPP_calc = cpu_clock_id('Ocean KPP calculate)', grain=CLOCK_MODULE) + id_clock_KPP_compute_BLD = cpu_clock_id('Ocean KPP comp BLD)', grain=CLOCK_ROUTINE) end function KPP_init @@ -643,6 +652,7 @@ subroutine KPP_calculate(CS, G, GV, US, h, uStar, & if (CS%id_Kd_in > 0) call post_data(CS%id_Kd_in, Kt, CS%diag) + call cpu_clock_begin(id_clock_KPP_calc) buoy_scale = US%L_to_m**2*US%s_to_T**3 !$OMP parallel do default(none) firstprivate(nonLocalTrans) & @@ -863,6 +873,7 @@ subroutine KPP_calculate(CS, G, GV, US, h, uStar, & enddo ! i enddo ! j + call cpu_clock_end(id_clock_KPP_calc) #ifdef __DO_SAFETY_CHECKS__ if (CS%debug) then @@ -962,6 +973,8 @@ subroutine KPP_compute_BLD(CS, G, GV, US, h, Temp, Salt, u, v, EOS, uStar, buoyF endif #endif + !call cpu_clock_begin(id_clock_KPP_compute_BLD) + ! some constants GoRho = GV%mks_g_Earth / (US%R_to_kg_m3*GV%Rho0) buoy_scale = US%L_to_m**2*US%s_to_T**3 @@ -1327,6 +1340,8 @@ subroutine KPP_compute_BLD(CS, G, GV, US, h, Temp, Salt, u, v, EOS, uStar, buoyF enddo enddo + !call cpu_clock_end(id_clock_KPP_compute_BLD) + ! 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) @@ -1367,15 +1382,20 @@ subroutine KPP_smooth_BLD(CS,G,GV,h) real :: pref integer :: i, j, k, s + !call cpu_clock_begin(id_clock_KPP_smoothing) + ! Update halos call pass_var(CS%OBLdepth, G%Domain, halo=CS%n_smooth) + do s=1,CS%n_smooth OBLdepth_original = CS%OBLdepth if (CS%id_OBLdepth_original > 0) CS%OBLdepth_original = OBLdepth_original ! apply smoothing on OBL depth + !$OMP parallel do default(none) shared(G, GV, CS, h, OBLdepth_original) & + !$OMP private(wc, ww, we, wn, ws, dh, hcorr, pref, cellHeight, iFaceHeight) do j = G%jsc, G%jec do i = G%isc, G%iec @@ -1420,6 +1440,8 @@ subroutine KPP_smooth_BLD(CS,G,GV,h) enddo ! s-loop + !call cpu_clock_end(id_clock_KPP_smoothing) + end subroutine KPP_smooth_BLD @@ -1432,6 +1454,7 @@ subroutine KPP_get_BLD(CS, BLD, G) real, dimension(SZI_(G),SZJ_(G)), intent(inout) :: BLD!< bnd. layer depth [m] ! Local variables integer :: i,j + !$OMP parallel do default(none) shared(BLD, CS, G) do j = G%jsc, G%jec ; do i = G%isc, G%iec BLD(i,j) = CS%OBLdepth(i,j) enddo ; enddo @@ -1469,6 +1492,7 @@ subroutine KPP_NonLocalTransport_temp(CS, G, GV, h, nonLocalTrans, surfFlux, & ! Update tracer due to non-local redistribution of surface flux if (CS%applyNonLocalTrans) then + !$OMP parallel do default(none) shared(dt, scalar, dtracer, G) do k = 1, G%ke do j = G%jsc, G%jec do i = G%isc, G%iec @@ -1483,6 +1507,7 @@ subroutine KPP_NonLocalTransport_temp(CS, G, GV, h, nonLocalTrans, surfFlux, & if (CS%id_NLT_dTdt > 0) call post_data(CS%id_NLT_dTdt, dtracer, CS%diag) if (CS%id_NLT_temp_budget > 0) then dtracer(:,:,:) = 0.0 + !$OMP parallel do default(none) shared(dtracer, nonLocalTrans, surfFlux, C_p, G, GV) do k = 1, G%ke do j = G%jsc, G%jec do i = G%isc, G%iec @@ -1528,6 +1553,7 @@ subroutine KPP_NonLocalTransport_saln(CS, G, GV, h, nonLocalTrans, surfFlux, dt, ! Update tracer due to non-local redistribution of surface flux if (CS%applyNonLocalTrans) then + !$OMP parallel do default(none) shared(G, dt, scalar, dtracer) do k = 1, G%ke do j = G%jsc, G%jec do i = G%isc, G%iec @@ -1542,6 +1568,7 @@ subroutine KPP_NonLocalTransport_saln(CS, G, GV, h, nonLocalTrans, surfFlux, dt, if (CS%id_NLT_dSdt > 0) call post_data(CS%id_NLT_dSdt, dtracer, CS%diag) if (CS%id_NLT_saln_budget > 0) then dtracer(:,:,:) = 0.0 + !$OMP parallel do default(none) shared(G, GV, dtracer, nonLocalTrans, surfFlux) do k = 1, G%ke do j = G%jsc, G%jec do i = G%isc, G%iec From e5fcc694d57cacd19229210a18960d28427f581b Mon Sep 17 00:00:00 2001 From: alperaltuntas Date: Wed, 22 Apr 2020 10:30:42 -0600 Subject: [PATCH 228/316] remove OMP enclosing get_BLD call --- src/parameterizations/vertical/MOM_CVMix_KPP.F90 | 4 ++-- src/parameterizations/vertical/MOM_diabatic_driver.F90 | 2 -- 2 files changed, 2 insertions(+), 4 deletions(-) diff --git a/src/parameterizations/vertical/MOM_CVMix_KPP.F90 b/src/parameterizations/vertical/MOM_CVMix_KPP.F90 index b17d91ff8d..c155bf56c7 100644 --- a/src/parameterizations/vertical/MOM_CVMix_KPP.F90 +++ b/src/parameterizations/vertical/MOM_CVMix_KPP.F90 @@ -241,7 +241,7 @@ logical function KPP_init(paramFile, G, GV, US, diag, Time, CS, passive, Waves) 'If true, apply OBLdepth smoothing at a cell only if the OBLdepth '// & 'gets deeper via smoothing.', & default=.false.) - id_clock_KPP_smoothing = cpu_clock_id('Ocean KPP BLD smoothing)', grain=CLOCK_ROUTINE) + id_clock_KPP_smoothing = cpu_clock_id('(Ocean KPP BLD smoothing)', grain=CLOCK_ROUTINE) endif call get_param(paramFile, mdl, 'RI_CRIT', CS%Ri_crit, & 'Critical bulk Richardson number used to define depth of the '// & @@ -590,7 +590,7 @@ logical function KPP_init(paramFile, G, GV, US, diag, Time, CS, passive, Waves) if (CS%id_EnhK > 0) CS%EnhK(:,:,:) = 0. id_clock_KPP_calc = cpu_clock_id('Ocean KPP calculate)', grain=CLOCK_MODULE) - id_clock_KPP_compute_BLD = cpu_clock_id('Ocean KPP comp BLD)', grain=CLOCK_ROUTINE) + id_clock_KPP_compute_BLD = cpu_clock_id('(Ocean KPP comp BLD)', grain=CLOCK_ROUTINE) end function KPP_init diff --git a/src/parameterizations/vertical/MOM_diabatic_driver.F90 b/src/parameterizations/vertical/MOM_diabatic_driver.F90 index 38cecf0425..369852ce23 100644 --- a/src/parameterizations/vertical/MOM_diabatic_driver.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_driver.F90 @@ -1448,9 +1448,7 @@ subroutine diabatic_ALE(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, Kd_salt, visc%Kv_shear, CS%KPP_NLTheat, CS%KPP_NLTscalar, Waves=Waves) if (associated(Hml)) then - !$OMP parallel default(shared) call KPP_get_BLD(CS%KPP_CSp, Hml(:,:), G) - !$OMP end parallel call pass_var(Hml, G%domain, halo=1) ! If visc%MLD exists, copy KPP's BLD into it if (associated(visc%MLD)) visc%MLD(:,:) = Hml(:,:) From e47e8b712c8dde2abbeb89d58f2fe12bde29c303 Mon Sep 17 00:00:00 2001 From: alperaltuntas Date: Wed, 22 Apr 2020 11:05:40 -0600 Subject: [PATCH 229/316] uncomment KPP clocks --- src/parameterizations/vertical/MOM_CVMix_KPP.F90 | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/parameterizations/vertical/MOM_CVMix_KPP.F90 b/src/parameterizations/vertical/MOM_CVMix_KPP.F90 index c155bf56c7..bcf2037c12 100644 --- a/src/parameterizations/vertical/MOM_CVMix_KPP.F90 +++ b/src/parameterizations/vertical/MOM_CVMix_KPP.F90 @@ -973,7 +973,7 @@ subroutine KPP_compute_BLD(CS, G, GV, US, h, Temp, Salt, u, v, EOS, uStar, buoyF endif #endif - !call cpu_clock_begin(id_clock_KPP_compute_BLD) + call cpu_clock_begin(id_clock_KPP_compute_BLD) ! some constants GoRho = GV%mks_g_Earth / (US%R_to_kg_m3*GV%Rho0) @@ -1340,7 +1340,7 @@ subroutine KPP_compute_BLD(CS, G, GV, US, h, Temp, Salt, u, v, EOS, uStar, buoyF enddo enddo - !call cpu_clock_end(id_clock_KPP_compute_BLD) + call cpu_clock_end(id_clock_KPP_compute_BLD) ! send diagnostics to post_data if (CS%id_BulkRi > 0) call post_data(CS%id_BulkRi, CS%BulkRi, CS%diag) @@ -1382,7 +1382,7 @@ subroutine KPP_smooth_BLD(CS,G,GV,h) real :: pref integer :: i, j, k, s - !call cpu_clock_begin(id_clock_KPP_smoothing) + call cpu_clock_begin(id_clock_KPP_smoothing) ! Update halos call pass_var(CS%OBLdepth, G%Domain, halo=CS%n_smooth) @@ -1440,7 +1440,7 @@ subroutine KPP_smooth_BLD(CS,G,GV,h) enddo ! s-loop - !call cpu_clock_end(id_clock_KPP_smoothing) + call cpu_clock_end(id_clock_KPP_smoothing) end subroutine KPP_smooth_BLD From 1165a61ba18b01967dc90f28cfc3428aa4e9bd7f Mon Sep 17 00:00:00 2001 From: alperaltuntas Date: Wed, 22 Apr 2020 15:11:17 -0600 Subject: [PATCH 230/316] further refactor smoothing subroutine --- .../vertical/MOM_CVMix_KPP.F90 | 20 +++++++++---------- 1 file changed, 10 insertions(+), 10 deletions(-) diff --git a/src/parameterizations/vertical/MOM_CVMix_KPP.F90 b/src/parameterizations/vertical/MOM_CVMix_KPP.F90 index bcf2037c12..38a7bff4df 100644 --- a/src/parameterizations/vertical/MOM_CVMix_KPP.F90 +++ b/src/parameterizations/vertical/MOM_CVMix_KPP.F90 @@ -1371,7 +1371,7 @@ subroutine KPP_smooth_BLD(CS,G,GV,h) real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer/level thicknesses [H ~> m or kg m-2] ! local - real, dimension(SZI_(G),SZJ_(G)) :: OBLdepth_original ! Original OBL depths computed by CVMix + real, dimension(SZI_(G),SZJ_(G)) :: OBLdepth_prev ! OBLdepth before s.th smoothing iteration real, dimension( G%ke ) :: cellHeight ! Cell center heights referenced to surface [m] ! (negative in the ocean) real, dimension( G%ke+1 ) :: iFaceHeight ! Interface heights referenced to surface [m] @@ -1387,14 +1387,14 @@ subroutine KPP_smooth_BLD(CS,G,GV,h) ! Update halos call pass_var(CS%OBLdepth, G%Domain, halo=CS%n_smooth) + if (CS%id_OBLdepth_original > 0) CS%OBLdepth_original = CS%OBLdepth do s=1,CS%n_smooth - OBLdepth_original = CS%OBLdepth - if (CS%id_OBLdepth_original > 0) CS%OBLdepth_original = OBLdepth_original + OBLdepth_prev = CS%OBLdepth ! apply smoothing on OBL depth - !$OMP parallel do default(none) shared(G, GV, CS, h, OBLdepth_original) & + !$OMP parallel do default(none) shared(G, GV, CS, h, OBLdepth_prev) & !$OMP private(wc, ww, we, wn, ws, dh, hcorr, pref, cellHeight, iFaceHeight) do j = G%jsc, G%jec do i = G%isc, G%iec @@ -1423,14 +1423,14 @@ subroutine KPP_smooth_BLD(CS,G,GV,h) wn = 0.125 * G%mask2dT(i,j+1) wc = 1.0 - (ww+we+wn+ws) - 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%OBLdepth(i,j) = wc * OBLdepth_prev(i,j) & + + ww * OBLdepth_prev(i-1,j) & + + we * OBLdepth_prev(i+1,j) & + + ws * OBLdepth_prev(i,j-1) & + + wn * OBLdepth_prev(i,j+1) ! 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)) + if (CS%deepen_only) CS%OBLdepth(i,j) = max(CS%OBLdepth(i,j), OBLdepth_prev(i,j)) ! prevent OBL depths deeper than the bathymetric depth CS%OBLdepth(i,j) = min( CS%OBLdepth(i,j), -iFaceHeight(G%ke+1) ) ! no deeper than bottom From 66ae90573ca05ee0de3fe1634b909237d7211836 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 22 Apr 2020 21:40:40 -0400 Subject: [PATCH 231/316] +Add p_surf to pressures used to calculate density Optionally add surface pressure from the ice to equation of state calls. This is enabled with the new runtime parameter USE_PSURF_IN_EOS, which is false by default, preserving the old answers. These pressures should have been added all along for physical consistency, so the default should be changed to true and the option of doing things the previous way should eventually be obsoleted. To implement this there is a new pointer, tv%p_surf, in the thermo_var_ptrs type, an EOS_type argument to KPP_compute_BLD was replaced with a thermo_var_ptrs type, and a new optional argument to neutral_diffusion_calc_coeffs. By default all answers are bitwise identical, but there is a new element in a transparent public type and some minor changes to public interfaces, and there are is a new entry in the MOM_parameter_doc.all files. --- src/core/MOM.F90 | 9 +++++ src/core/MOM_forcing_type.F90 | 4 ++- src/core/MOM_interface_heights.F90 | 14 +++++--- src/core/MOM_isopycnal_slopes.F90 | 15 +++++--- src/core/MOM_variables.F90 | 2 ++ .../lateral/MOM_thickness_diffuse.F90 | 5 +-- .../vertical/MOM_CVMix_KPP.F90 | 15 ++++---- .../vertical/MOM_CVMix_conv.F90 | 2 +- .../vertical/MOM_CVMix_ddiff.F90 | 12 +++---- .../vertical/MOM_CVMix_shear.F90 | 10 +++--- .../vertical/MOM_bulk_mixed_layer.F90 | 6 +++- .../vertical/MOM_diabatic_aux.F90 | 11 ++++-- .../vertical/MOM_diabatic_driver.F90 | 6 ++-- .../vertical/MOM_set_diffusivity.F90 | 5 +-- .../vertical/MOM_set_viscosity.F90 | 13 ++++--- src/tracer/MOM_neutral_diffusion.F90 | 36 +++++++++++++------ src/tracer/MOM_tracer_hor_diff.F90 | 12 +++++-- 17 files changed, 120 insertions(+), 57 deletions(-) diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index 80cc36c577..e36ac4c958 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -252,6 +252,8 @@ module MOM 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 + logical :: use_p_surf_in_EOS !< If true, always include the surface pressure contributions + !! in equation of state calculations. real :: dtbt_reset_period !< The time interval between dynamic recalculation of the !! barotropic time step [s]. If this is negative dtbt is never !! calculated, and if it is 0, dtbt is calculated every step. @@ -566,6 +568,8 @@ subroutine step_MOM(forces_in, fluxes_in, sfc_state, Time_start, time_int_in, CS if (associated(forces%p_surf)) p_surf => forces%p_surf if (.not.associated(forces%p_surf)) CS%interp_p_surf = .false. + CS%tv%p_surf => NULL() + if (CS%use_p_surf_in_EOS .and. associated(forces%p_surf)) CS%tv%p_surf => forces%p_surf !---------- Initiate group halo pass of the forcing fields call cpu_clock_begin(id_clock_pass) @@ -589,6 +593,8 @@ subroutine step_MOM(forces_in, fluxes_in, sfc_state, Time_start, time_int_in, CS dt = time_interval / real(n_max) dt_therm = dt ; ntstep = 1 if (associated(fluxes%p_surf)) p_surf => fluxes%p_surf + CS%tv%p_surf => NULL() + if (CS%use_p_surf_in_EOS .and. associated(forces%p_surf)) CS%tv%p_surf => fluxes%p_surf if (CS%UseWaves) call pass_var(fluxes%ustar, G%Domain, clock=id_clock_pass) endif @@ -1896,6 +1902,9 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & "true. The default value is from the TEOS-10 definition "//& "of conservative temperature.", units="J kg-1 K-1", & default=3991.86795711963, scale=US%J_kg_to_Q) + call get_param(param_file, "MOM", "USE_PSURF_IN_EOS", CS%use_p_surf_in_EOS, & + "If true, always include the surface pressure contributions "//& + "in equation of state calculations.", default=.false.) !### Change the default. endif if (use_EOS) call get_param(param_file, "MOM", "P_REF", CS%tv%P_Ref, & "The pressure that is used for calculating the coordinate "//& diff --git a/src/core/MOM_forcing_type.F90 b/src/core/MOM_forcing_type.F90 index 34c83bd530..aea62826e3 100644 --- a/src/core/MOM_forcing_type.F90 +++ b/src/core/MOM_forcing_type.F90 @@ -926,13 +926,15 @@ subroutine calculateBuoyancyFlux1d(G, GV, US, fluxes, optics, nsw, h, Temp, Salt real :: GoRho ! The gravitational acceleration divided by mean density times some ! unit conversion factors [L2 H-1 s R-1 T-3 ~> m4 kg-1 s-2 or m7 kg-2 s-2] real :: H_limit_fluxes ! Another depth scale [H ~> m or kg m-2] + integer :: i ! smg: what do we do when have heat fluxes from calving and river? useRiverHeatContent = .False. useCalvingHeatContent = .False. depthBeforeScalingFluxes = max( GV%Angstrom_H, 1.e-30*GV%m_to_H ) - pressure(:) = 0. ! Ignores atmospheric pressure ### + pressure(:) = 0. + if (associated(tv%p_surf)) then ; do i=G%isc,G%iec ; pressure(i) = tv%p_surf(i,j) ; enddo ; endif GoRho = (GV%g_Earth * GV%H_to_Z*US%T_to_s) / GV%Rho0 H_limit_fluxes = depthBeforeScalingFluxes diff --git a/src/core/MOM_interface_heights.F90 b/src/core/MOM_interface_heights.F90 index ea529d42c5..fc775d938f 100644 --- a/src/core/MOM_interface_heights.F90 +++ b/src/core/MOM_interface_heights.F90 @@ -97,8 +97,11 @@ subroutine find_eta_3d(h, tv, G, GV, US, eta, eta_bt, halo_size, eta_to_m) if (associated(tv%eqn_of_state)) then !$OMP do do j=jsv,jev - ! ### THIS SHOULD BE P_SURF, IF AVAILABLE. - do i=isv,iev ; p(i,j,1) = 0.0 ; enddo + if (associated(tv%p_surf)) then + do i=isv,iev ; p(i,j,1) = tv%p_surf(i,j) ; enddo + else + do i=isv,iev ; p(i,j,1) = 0.0 ; enddo + endif do k=1,nz ; do i=isv,iev p(i,j,K+1) = p(i,j,K) + GV%g_Earth*GV%H_to_RZ*h(i,j,k) enddo ; enddo @@ -198,8 +201,11 @@ subroutine find_eta_2d(h, tv, G, GV, US, eta, eta_bt, halo_size, eta_to_m) if (associated(tv%eqn_of_state)) then !$OMP do do j=js,je - ! ### THIS SHOULD BE P_SURF, IF AVAILABLE. - do i=is,ie ; p(i,j,1) = 0.0 ; enddo + if (associated(tv%p_surf)) then + do i=is,ie ; p(i,j,1) = tv%p_surf(i,j) ; enddo + else + do i=is,ie ; p(i,j,1) = 0.0 ; enddo + endif do k=1,nz ; do i=is,ie p(i,j,k+1) = p(i,j,k) + GV%g_Earth*GV%H_to_RZ*h(i,j,k) diff --git a/src/core/MOM_isopycnal_slopes.F90 b/src/core/MOM_isopycnal_slopes.F90 index 4f1a2d261e..53f0d59294 100644 --- a/src/core/MOM_isopycnal_slopes.F90 +++ b/src/core/MOM_isopycnal_slopes.F90 @@ -145,10 +145,17 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, & endif ! Find the maximum and minimum permitted streamfunction. - !$OMP parallel do default(shared) - do j=js-1,je+1 ; do i=is-1,ie+1 - pres(i,j,1) = 0.0 ! ### This should be atmospheric pressure. - enddo ; enddo + if (associated(tv%p_surf)) then + !$OMP parallel do default(shared) + do j=js-1,je+1 ; do i=is-1,ie+1 + pres(i,j,1) = tv%p_surf(i,j) + enddo ; enddo + else + !$OMP parallel do default(shared) + do j=js-1,je+1 ; do i=is-1,ie+1 + pres(i,j,1) = 0.0 + enddo ; enddo + endif !$OMP parallel do default(shared) do j=js-1,je+1 do k=1,nz ; do i=is-1,ie+1 diff --git a/src/core/MOM_variables.F90 b/src/core/MOM_variables.F90 index 7908d130b8..2ac62eee5a 100644 --- a/src/core/MOM_variables.F90 +++ b/src/core/MOM_variables.F90 @@ -81,6 +81,8 @@ module MOM_variables ! If allocated, the following variables have nz layers. real, pointer :: T(:,:,:) => NULL() !< Potential temperature [degC]. real, pointer :: S(:,:,:) => NULL() !< Salnity [PSU] or [gSalt/kg], generically [ppt]. + real, pointer :: p_surf(:,:) => NULL() !< Ocean surface pressure used in equation of state + !! calculations [R L2 T-2 ~> Pa] type(EOS_type), pointer :: eqn_of_state => NULL() !< Type that indicates the !! equation of state to use. real :: P_Ref !< The coordinate-density reference pressure [R L2 T-2 ~> Pa]. diff --git a/src/parameterizations/lateral/MOM_thickness_diffuse.F90 b/src/parameterizations/lateral/MOM_thickness_diffuse.F90 index d988f2bbd5..3819dce047 100644 --- a/src/parameterizations/lateral/MOM_thickness_diffuse.F90 +++ b/src/parameterizations/lateral/MOM_thickness_diffuse.F90 @@ -714,13 +714,14 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV "cg1 must be associated when using FGNV streamfunction.") !$OMP parallel default(none) shared(is,ie,js,je,h_avail_rsum,pres,h_avail,I4dt, & -!$OMP G,GV,h,h_frac,nz,uhtot,Work_u,vhtot,Work_v, & +!$OMP G,GV,tv,h,h_frac,nz,uhtot,Work_u,vhtot,Work_v, & !$OMP diag_sfn_x, diag_sfn_y, diag_sfn_unlim_x, diag_sfn_unlim_y ) ! Find the maximum and minimum permitted streamfunction. !$OMP do do j=js-1,je+1 ; do i=is-1,ie+1 h_avail_rsum(i,j,1) = 0.0 - pres(i,j,1) = 0.0 ! ### This should be atmospheric pressure. + pres(i,j,1) = 0.0 + if (associated(tv%p_surf)) then ; pres(i,j,1) = tv%p_surf(i,j) ; endif h_avail(i,j,1) = max(I4dt*G%areaT(i,j)*(h(i,j,1)-GV%Angstrom_H),0.0) h_avail_rsum(i,j,2) = h_avail(i,j,1) diff --git a/src/parameterizations/vertical/MOM_CVMix_KPP.F90 b/src/parameterizations/vertical/MOM_CVMix_KPP.F90 index ea187f86f9..6ff6046350 100644 --- a/src/parameterizations/vertical/MOM_CVMix_KPP.F90 +++ b/src/parameterizations/vertical/MOM_CVMix_KPP.F90 @@ -12,7 +12,8 @@ module MOM_CVMix_KPP 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_unit_scaling, only : unit_scale_type +use MOM_unit_scaling, only : unit_scale_type +use MOM_variables, only : thermo_var_ptrs use MOM_verticalGrid, only : verticalGrid_type use MOM_wave_interface, only : wave_parameters_CS, Get_Langmuir_Number use MOM_domains, only : pass_var @@ -886,7 +887,7 @@ end subroutine KPP_calculate !> Compute OBL depth -subroutine KPP_compute_BLD(CS, G, GV, US, h, Temp, Salt, u, v, EOS, uStar, buoyFlux, Waves) +subroutine KPP_compute_BLD(CS, G, GV, US, h, Temp, Salt, u, v, tv, uStar, buoyFlux, Waves) ! Arguments type(KPP_CS), pointer :: CS !< Control structure @@ -898,7 +899,7 @@ subroutine KPP_compute_BLD(CS, G, GV, US, h, Temp, Salt, u, v, EOS, uStar, buoyF 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 [L T-1 ~> m s-1] real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(in) :: v !< Velocity j-component [L T-1 ~> m s-1] - type(EOS_type), pointer :: EOS !< Equation of state + type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamics structure. real, dimension(SZI_(G),SZJ_(G)), intent(in) :: uStar !< Surface friction velocity [Z T-1 ~> m s-1] real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1), intent(in) :: buoyFlux !< Surface buoyancy flux [L2 T-3 ~> m2 s-3] type(wave_parameters_CS), optional, pointer :: Waves !< Wave CS @@ -973,7 +974,7 @@ subroutine KPP_compute_BLD(CS, G, GV, US, h, Temp, Salt, u, v, EOS, uStar, buoyF !GOMP deltarho, N2_1d, ws_1d, LangEnhVT2, enhvt2, wst, & !GOMP BulkRi_1d, zBottomMinusOffset) & !GOMP shared(G, GV, CS, US, uStar, h, buoy_scale, buoyFlux, & - !GOMP Temp, Salt, waves, EOS, GoRho) + !GOMP Temp, Salt, waves, tv, GoRho) do j = G%jsc, G%jec do i = G%isc, G%iec @@ -997,7 +998,7 @@ subroutine KPP_compute_BLD(CS, G, GV, US, h, Temp, Salt, u, v, EOS, uStar, buoyF ! 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. + pRef = 0. ; if (associated(tv%p_surf)) pRef = tv%p_surf(i,j) hcorr = 0. do k=1,G%ke @@ -1104,7 +1105,7 @@ subroutine KPP_compute_BLD(CS, G, GV, US, h, Temp, Salt, u, v, EOS, uStar, buoyF ! compute in-situ density - call calculate_density(Temp_1D, Salt_1D, pres_1D, rho_1D, EOS) + call calculate_density(Temp_1D, Salt_1D, pres_1D, rho_1D, tv%eqn_of_state) ! N2 (can be negative) and N (non-negative) on interfaces. ! deltaRho is non-local rho difference used for bulk Richardson number. @@ -1281,7 +1282,6 @@ subroutine KPP_smooth_BLD(CS,G,GV,h) 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 do s=1,CS%n_smooth @@ -1300,7 +1300,6 @@ subroutine KPP_smooth_BLD(CS,G,GV,h) 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 diff --git a/src/parameterizations/vertical/MOM_CVMix_conv.F90 b/src/parameterizations/vertical/MOM_CVMix_conv.F90 index 0bd312d95d..0b1abba577 100644 --- a/src/parameterizations/vertical/MOM_CVMix_conv.F90 +++ b/src/parameterizations/vertical/MOM_CVMix_conv.F90 @@ -195,7 +195,7 @@ subroutine calculate_CVMix_conv(h, tv, G, GV, US, CS, hbl) ! skip calling at land points !if (G%mask2dT(i,j) == 0.) cycle - pRef = 0. + pRef = 0. ; if (associated(tv%p_surf)) pRef = tv%p_surf(i,j) ! Compute Brunt-Vaisala frequency (static stability) on interfaces do k=2,G%ke diff --git a/src/parameterizations/vertical/MOM_CVMix_ddiff.F90 b/src/parameterizations/vertical/MOM_CVMix_ddiff.F90 index dd398cae6f..94cb958632 100644 --- a/src/parameterizations/vertical/MOM_CVMix_ddiff.F90 +++ b/src/parameterizations/vertical/MOM_CVMix_ddiff.F90 @@ -219,19 +219,19 @@ subroutine compute_ddiff_coeffs(h, tv, G, GV, US, j, Kd_T, Kd_S, CS) ! skip calling at land points if (G%mask2dT(i,j) == 0.) cycle - pres_int(1) = 0. + pres_int(1) = 0. ; if (associated(tv%p_surf)) pres_int(1) = tv%p_surf(i,j) ! 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) + 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) = pres_int(K-1) + (GV%g_Earth * GV%H_to_RZ) * 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)) + 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)) + 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)) enddo ! k-loop finishes call calculate_density_derivs(temp_int, salt_int, pres_int, drho_dT, drho_dS, tv%eqn_of_state) diff --git a/src/parameterizations/vertical/MOM_CVMix_shear.F90 b/src/parameterizations/vertical/MOM_CVMix_shear.F90 index d1e2668c62..6f1a629ab4 100644 --- a/src/parameterizations/vertical/MOM_CVMix_shear.F90 +++ b/src/parameterizations/vertical/MOM_CVMix_shear.F90 @@ -100,7 +100,7 @@ subroutine calculate_CVMix_shear(u_H, v_H, h, tv, kd, kv, G, GV, US, CS ) if (G%mask2dT(i,j)==0.) cycle ! Richardson number computed for each cell in a column. - pRef = 0. + pRef = 0. ; if (associated(tv%p_surf)) pRef = tv%p_surf(i,j) Ri_Grad(:)=1.e8 !Initialize w/ large Richardson value do k=1,G%ke ! pressure, temp, and saln for EOS @@ -110,10 +110,10 @@ subroutine calculate_CVMix_shear(u_H, v_H, h, tv, kd, kv, G, GV, US, CS ) kk = 2*(k-1) pres_1D(kk+1) = pRef pres_1D(kk+2) = pRef - Temp_1D(kk+1) = TV%T(i,j,k) - Temp_1D(kk+2) = TV%T(i,j,km1) - Salt_1D(kk+1) = TV%S(i,j,k) - Salt_1D(kk+2) = TV%S(i,j,km1) + Temp_1D(kk+1) = tv%T(i,j,k) + Temp_1D(kk+2) = tv%T(i,j,km1) + Salt_1D(kk+1) = tv%S(i,j,k) + Salt_1D(kk+2) = tv%S(i,j,km1) ! pRef is pressure at interface between k and km1. ! iterate pRef for next pass through k-loop. diff --git a/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 b/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 index 1082bb74e4..28b1b8cc0b 100644 --- a/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 +++ b/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 @@ -464,7 +464,11 @@ subroutine bulkmixedlayer(h_3d, u_3d, v_3d, tv, fluxes, dt, ea, eb, G, GV, US, C if (id_clock_EOS>0) call cpu_clock_begin(id_clock_EOS) ! Calculate an estimate of the mid-mixed layer pressure [R L2 T-2 ~> Pa] - do i=is,ie ; p_ref(i) = 0.0 ; enddo + if (associated(tv%p_surf)) then + do i=is,ie ; p_ref(i) = tv%p_surf(i,j) ; enddo + else + do i=is,ie ; p_ref(i) = 0.0 ; enddo + endif do k=1,CS%nkml ; do i=is,ie p_ref(i) = p_ref(i) + 0.5*(GV%H_to_RZ*GV%g_Earth)*h(i,k) enddo ; enddo diff --git a/src/parameterizations/vertical/MOM_diabatic_aux.F90 b/src/parameterizations/vertical/MOM_diabatic_aux.F90 index 92288db846..85e009bf27 100644 --- a/src/parameterizations/vertical/MOM_diabatic_aux.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_aux.F90 @@ -960,8 +960,8 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t if (present(cTKE)) cTKE(:,:,:) = 0.0 if (calculate_buoyancy) then - SurfPressure(:) = 0.0 !### Add fluxes%p_surf_full? - GoRho = US%L_to_Z**2*GV%g_Earth / GV%Rho0 + SurfPressure(:) = 0.0 + GoRho = US%L_to_Z**2*GV%g_Earth / GV%Rho0 endif ! H_limit_fluxes is used by extractFluxes1d to scale down fluxes if the total @@ -1004,7 +1004,11 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t ! The partial derivatives of specific volume with temperature and ! salinity need to be precalculated to avoid having heating of ! tiny layers give nonsensical values. - do i=is,ie ; pres(i) = 0.0 ; enddo ! ###Add surface pressure? + if (associated(tv%p_surf)) then + do i=is,ie ; pres(i) = tv%p_surf(i,j) ; enddo + else + do i=is,ie ; pres(i) = 0.0 ; enddo + endif do k=1,nz do i=is,ie d_pres(i) = (GV%g_Earth * GV%H_to_RZ) * h2d(i,k) @@ -1353,6 +1357,7 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t do i=is,ie ; do nb=1,nsw ; netPen_rate(i) = netPen_rate(i) + pen_SW_bnd_rate(nb,i) ; enddo ; enddo ! Density derivatives + if (associated(tv%p_surf)) then ; do i=is,ie ; SurfPressure(i) = tv%p_surf(i,j) ; enddo ; endif call calculate_density_derivs(T2d(:,1), tv%S(:,j,1), SurfPressure, dRhodT, dRhodS, & tv%eqn_of_state, EOSdom) ! 1. Adjust netSalt to reflect dilution effect of FW flux diff --git a/src/parameterizations/vertical/MOM_diabatic_driver.F90 b/src/parameterizations/vertical/MOM_diabatic_driver.F90 index 1ee10cebec..69c800d218 100644 --- a/src/parameterizations/vertical/MOM_diabatic_driver.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_driver.F90 @@ -656,7 +656,7 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Tim 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, US, h, tv%T, tv%S, u, v, tv%eqn_of_state, & + call KPP_compute_BLD(CS%KPP_CSp, G, GV, US, h, tv%T, tv%S, u, v, tv, & fluxes%ustar, CS%KPP_buoy_flux, Waves=Waves) call KPP_calculate(CS%KPP_CSp, G, GV, US, h, fluxes%ustar, CS%KPP_buoy_flux, Kd_heat, & @@ -1441,7 +1441,7 @@ subroutine diabatic_ALE(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, 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, US, h, tv%T, tv%S, u, v, tv%eqn_of_state, & + call KPP_compute_BLD(CS%KPP_CSp, G, GV, US, h, tv%T, tv%S, u, v, tv, & fluxes%ustar, CS%KPP_buoy_flux, Waves=Waves) call KPP_calculate(CS%KPP_CSp, G, GV, US, h, fluxes%ustar, CS%KPP_buoy_flux, Kd_heat, & @@ -2176,7 +2176,7 @@ subroutine layered_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_e enddo ; enddo ; enddo endif - call KPP_compute_BLD(CS%KPP_CSp, G, GV, US, h, tv%T, tv%S, u, v, tv%eqn_of_state, & + call KPP_compute_BLD(CS%KPP_CSp, G, GV, US, h, tv%T, tv%S, u, v, tv, & fluxes%ustar, CS%KPP_buoy_flux, Waves=Waves) call KPP_calculate(CS%KPP_CSp, G, GV, US, h, fluxes%ustar, CS%KPP_buoy_flux, Kd_heat, & diff --git a/src/parameterizations/vertical/MOM_set_diffusivity.F90 b/src/parameterizations/vertical/MOM_set_diffusivity.F90 index 2ee3f38233..9d03b11f7b 100644 --- a/src/parameterizations/vertical/MOM_set_diffusivity.F90 +++ b/src/parameterizations/vertical/MOM_set_diffusivity.F90 @@ -1058,10 +1058,11 @@ subroutine double_diffusion(tv, h, T_f, S_f, j, G, GV, US, CS, Kd_T_dd, Kd_S_dd) is = G%isc ; ie = G%iec ; nz = G%ke if (associated(tv%eqn_of_state)) then - do i=is,ie !### Add surface pressure. + do i=is,ie pres(i) = 0.0 ; Kd_T_dd(i,1) = 0.0 ; Kd_S_dd(i,1) = 0.0 Kd_T_dd(i,nz+1) = 0.0 ; Kd_S_dd(i,nz+1) = 0.0 enddo + if (associated(tv%p_surf)) then ; do i=is,ie ; pres(i) = tv%p_surf(i,j) ; enddo ; endif EOSdom(:) = EOS_domain(G%HI) do K=2,nz do i=is,ie @@ -1408,7 +1409,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 - !### Examine this question of whether there is double counting of fluxes%ustar_tidal. + !### Examine the question of whether there is double counting of fluxes%ustar_tidal. 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 diff --git a/src/parameterizations/vertical/MOM_set_viscosity.F90 b/src/parameterizations/vertical/MOM_set_viscosity.F90 index be16133ed1..0046cd8b18 100644 --- a/src/parameterizations/vertical/MOM_set_viscosity.F90 +++ b/src/parameterizations/vertical/MOM_set_viscosity.F90 @@ -567,10 +567,13 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, symmetrize) endif ! Not linear_drag if (use_BBL_EOS) then - do i=is,ie - press(i) = 0.0 ! or = forces%p_surf(i) !### - if (.not.do_i(i)) then ; T_EOS(i) = 0.0 ; S_EOS(i) = 0.0 ; endif - enddo + if (associated(tv%p_surf)) then + if (m==1) then ; do i=is,ie ; press(I) = 0.5*(tv%p_surf(i,j) + tv%p_surf(i+1,j)) ; enddo + else ; do i=is,ie ; press(i) = 0.5*(tv%p_surf(i,j) + tv%p_surf(i,j+1)) ; enddo ; endif + else + do i=is,ie ; press(i) = 0.0 ; enddo + endif + do i=is,ie ; if (.not.do_i(i)) then ; T_EOS(i) = 0.0 ; S_EOS(i) = 0.0 ; endif ; enddo do k=1,nz ; do i=is,ie press(i) = press(i) + (GV%H_to_RZ*GV%g_Earth) * h_vel(i,k) enddo ; enddo @@ -1273,6 +1276,7 @@ subroutine set_viscous_ML(u, v, h, tv, forces, visc, dt, G, GV, US, CS, symmetri ! Find dRho/dT and dRho_dS. do I=Isq,Ieq press(I) = (GV%H_to_RZ*GV%g_Earth) * htot(I) + if (associated(tv%p_surf)) press(I) = press(I) + 0.5*(tv%p_surf(i,j)+tv%p_surf(i+1,j)) k2 = max(1,nkml) I_2hlay = 1.0 / (h(i,j,k2) + h(i+1,j,k2) + h_neglect) T_EOS(I) = (h(i,j,k2)*tv%T(i,j,k2) + h(i+1,j,k2)*tv%T(i+1,j,k2)) * I_2hlay @@ -1510,6 +1514,7 @@ subroutine set_viscous_ML(u, v, h, tv, forces, visc, dt, G, GV, US, CS, symmetri ! Find dRho/dT and dRho_dS. do i=is,ie press(i) = (GV%H_to_RZ * GV%g_Earth) * htot(i) + if (associated(tv%p_surf)) press(i) = press(i) + 0.5*(tv%p_surf(i,j)+tv%p_surf(i,j+1)) k2 = max(1,nkml) I_2hlay = 1.0 / (h(i,j,k2) + h(i,j+1,k2) + h_neglect) T_EOS(i) = (h(i,j,k2)*tv%T(i,j,k2) + h(i,j+1,k2)*tv%T(i,j+1,k2)) * I_2hlay diff --git a/src/tracer/MOM_neutral_diffusion.F90 b/src/tracer/MOM_neutral_diffusion.F90 index ac7324c143..48678e1107 100644 --- a/src/tracer/MOM_neutral_diffusion.F90 +++ b/src/tracer/MOM_neutral_diffusion.F90 @@ -280,7 +280,7 @@ end function neutral_diffusion_init !> Calculate remapping factors for u/v columns used to map adjoining columns to !! a shared coordinate space. -subroutine neutral_diffusion_calc_coeffs(G, GV, US, h, T, S, CS) +subroutine neutral_diffusion_calc_coeffs(G, GV, US, h, T, S, CS, p_surf) type(ocean_grid_type), intent(in) :: G !< Ocean grid structure type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type @@ -288,6 +288,8 @@ subroutine neutral_diffusion_calc_coeffs(G, GV, US, h, T, S, CS) real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: T !< Potential temperature [degC] real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: S !< Salinity [ppt] type(neutral_diffusion_CS), pointer :: CS !< Neutral diffusion control structure + real, dimension(SZI_(G),SZJ_(G)), optional, intent(in) :: p_surf !< Surface pressure to include in pressures used + !! for equation of state calculations [R L2 T-2 ~> Pa] ! Local variables integer, dimension(2) :: EOSdom ! The i-computational domain for the equation of state @@ -350,21 +352,33 @@ subroutine neutral_diffusion_calc_coeffs(G, GV, US, h, T, S, CS) CS%stable_cell(:,:,:) = .true. endif - ! ### Consider adding the surface pressures to both Pint and P_i. ! Calculate pressure at interfaces and layer averaged alpha/beta - CS%Pint(:,:,1) = 0. - do k=1,G%ke ; do j=G%jsc-1, G%jec+1 ; do i=G%isc-1,G%iec+1 + if (present(p_surf)) then + do j=G%jsc-1,G%jec+1 ; do i=G%isc-1,G%iec+1 + CS%Pint(i,j,1) = p_surf(i,j) + enddo ; enddo + else + CS%Pint(:,:,1) = 0. + endif + do k=1,G%ke ; do j=G%jsc-1,G%jec+1 ; do i=G%isc-1,G%iec+1 CS%Pint(i,j,k+1) = CS%Pint(i,j,k) + h(i,j,k)*(GV%g_Earth*GV%H_to_RZ) enddo ; enddo ; enddo - ! Pressures at the interfaces, this is redundant as P_i(k,1) = P_i(k-1,2) however retain tis - ! for now ensure consitency of indexing for diiscontinuous reconstructions + ! Pressures at the interfaces, this is redundant as P_i(k,1) = P_i(k-1,2) however retain this + ! for now to ensure consitency of indexing for diiscontinuous reconstructions if (.not. CS%continuous_reconstruction) then - do j=G%jsc-1, G%jec+1 ; do i=G%isc-1,G%iec+1 - CS%P_i(i,j,1,1) = 0. - CS%P_i(i,j,1,2) = h(i,j,1)*(GV%H_to_RZ*GV%g_Earth) - enddo ; enddo - do k=2,G%ke ; do j=G%jsc-1, G%jec+1 ; do i=G%isc-1,G%iec+1 + if (present(p_surf)) then + do j=G%jsc-1,G%jec+1 ; do i=G%isc-1,G%iec+1 + CS%P_i(i,j,1,1) = p_surf(i,j) + CS%P_i(i,j,1,2) = p_surf(i,j) + h(i,j,1)*(GV%H_to_RZ*GV%g_Earth) + enddo ; enddo + else + do j=G%jsc-1,G%jec+1 ; do i=G%isc-1,G%iec+1 + CS%P_i(i,j,1,1) = 0. + CS%P_i(i,j,1,2) = h(i,j,1)*(GV%H_to_RZ*GV%g_Earth) + enddo ; enddo + endif + do k=2,G%ke ; do j=G%jsc-1,G%jec+1 ; do i=G%isc-1,G%iec+1 CS%P_i(i,j,k,1) = CS%P_i(i,j,k-1,2) CS%P_i(i,j,k,2) = CS%P_i(i,j,k-1,2) + h(i,j,k)*(GV%H_to_RZ*GV%g_Earth) enddo ; enddo ; enddo diff --git a/src/tracer/MOM_tracer_hor_diff.F90 b/src/tracer/MOM_tracer_hor_diff.F90 index 6898af23da..cdbaaf28b9 100644 --- a/src/tracer/MOM_tracer_hor_diff.F90 +++ b/src/tracer/MOM_tracer_hor_diff.F90 @@ -421,7 +421,11 @@ subroutine tracer_hordiff(h, dt, MEKE, VarMix, G, GV, US, CS, Reg, tv, do_online ! lateral diffusion iterations. Otherwise the call to neutral_diffusion_calc_coeffs() ! would be inside the itt-loop. -AJA - call neutral_diffusion_calc_coeffs(G, GV, US, h, tv%T, tv%S, CS%neutral_diffusion_CSp) + if (associated(tv%p_surf)) then + call neutral_diffusion_calc_coeffs(G, GV, US, h, tv%T, tv%S, CS%neutral_diffusion_CSp, p_surf=tv%p_surf) + else + call neutral_diffusion_calc_coeffs(G, GV, US, h, tv%T, tv%S, CS%neutral_diffusion_CSp) + endif do J=js-1,je ; do i=is,ie Coef_y(i,J) = I_numitts * khdt_y(i,J) enddo ; enddo @@ -436,7 +440,11 @@ subroutine tracer_hordiff(h, dt, MEKE, VarMix, G, GV, US, CS, Reg, tv, do_online if (itt>1) then ! Update halos for subsequent iterations call do_group_pass(CS%pass_t, G%Domain, clock=id_clock_pass) if (CS%recalc_neutral_surf) then - call neutral_diffusion_calc_coeffs(G, GV, US, h, tv%T, tv%S, CS%neutral_diffusion_CSp) + if (associated(tv%p_surf)) then + call neutral_diffusion_calc_coeffs(G, GV, US, h, tv%T, tv%S, CS%neutral_diffusion_CSp, p_surf=tv%p_surf) + else + call neutral_diffusion_calc_coeffs(G, GV, US, h, tv%T, tv%S, CS%neutral_diffusion_CSp) + endif endif endif call neutral_diffusion(G, GV, h, Coef_x, Coef_y, I_numitts*dt, Reg, US, CS%neutral_diffusion_CSp) From 98f5a8d97637d71c075a9f3f0b2ab1009f3836bd Mon Sep 17 00:00:00 2001 From: alperaltuntas Date: Wed, 22 Apr 2020 22:44:35 -0600 Subject: [PATCH 232/316] add omp directives to int_density_dz_generic_plm --- src/equation_of_state/MOM_EOS.F90 | 292 +++++++++++++++--------------- 1 file changed, 151 insertions(+), 141 deletions(-) diff --git a/src/equation_of_state/MOM_EOS.F90 b/src/equation_of_state/MOM_EOS.F90 index 5d3d33534b..c26317d3a9 100644 --- a/src/equation_of_state/MOM_EOS.F90 +++ b/src/equation_of_state/MOM_EOS.F90 @@ -1270,6 +1270,8 @@ subroutine int_density_dz_generic_plm (T_t, T_b, S_t, S_b, z_t, z_b, rho_ref, & ! ============================= ! 1. Compute vertical integrals ! ============================= + + !$OMP parallel do default(shared) private(jin,iin,dz,p5,S5,T5,r5,rho_anom) do j=Jsq,Jeq+1 jin = j+joff do i = Isq,Ieq+1 ; iin = i+ioff @@ -1300,163 +1302,171 @@ 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 = 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)) - - ! 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 - - 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 - - ! 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) + if (present(intx_dpa)) then + !$OMP parallel do default(shared) private(jin,iin,hWght,hL,hR,iDenom,Ttl,Ttr,Tbl,Tbr,Stl,Str,Sbl,Sbr, & + !$OMP w_left,w_right,dz_x,pos,T15,S15,p15,r15,weight_t,weight_b,intz) + 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 = 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)) + + ! 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 + + 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 + + ! 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, rho_ref) + 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) + do I=Isq,Ieq ; iin = i+ioff + 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))) + ! 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))) + 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)) + & + 12.0*intz(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)) + & - 12.0*intz(3)) enddo - enddo ; endif + endif ! ================================================== ! 3. Compute horizontal integrals in the y direction ! ================================================== - if (present(inty_dpa)) then ; do J=Jsq,Jeq ; jin = j+joff - do i=HIO%isc,HIO%iec ; 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(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 - hR = (z_t(iin,jin+1) - z_b(iin,jin+1)) + dz_subroundoff - hWght = hWght * ( (hL-hR)/(hL+hR) )**2 - iDenom = 1./( hWght*(hR + hL) + hL*hR ) - Ttl = ( (hWght*hR)*T_t(iin,jin+1) + (hWght*hL + hR*hL)*T_t(iin,jin) ) * iDenom - Ttr = ( (hWght*hL)*T_t(iin,jin) + (hWght*hR + hR*hL)*T_t(iin,jin+1) ) * iDenom - Tbl = ( (hWght*hR)*T_b(iin,jin+1) + (hWght*hL + hR*hL)*T_b(iin,jin) ) * iDenom - Tbr = ( (hWght*hL)*T_b(iin,jin) + (hWght*hR + hR*hL)*T_b(iin,jin+1) ) * iDenom - Stl = ( (hWght*hR)*S_t(iin,jin+1) + (hWght*hL + hR*hL)*S_t(iin,jin) ) * iDenom - Str = ( (hWght*hL)*S_t(iin,jin) + (hWght*hR + hR*hL)*S_t(iin,jin+1) ) * iDenom - Sbl = ( (hWght*hR)*S_b(iin,jin+1) + (hWght*hL + hR*hL)*S_b(iin,jin) ) * iDenom - Sbr = ( (hWght*hL)*S_b(iin,jin) + (hWght*hR + hR*hL)*S_b(iin,jin+1) ) * iDenom - else - Ttl = T_t(iin,jin); Tbl = T_b(iin,jin); Ttr = T_t(iin,jin+1); Tbr = T_b(iin,jin+1) - Stl = S_t(iin,jin); Sbl = S_b(iin,jin); Str = S_t(iin,jin+1); Sbr = S_b(iin,jin+1) - endif - - do m=2,4 - w_left = 0.25*real(5-m) ; w_right = 1.0-w_left - dz_y(m,i) = w_left*(z_t(iin,jin) - z_b(iin,jin)) + w_right*(z_t(iin,jin+1) - z_b(iin,jin+1)) - - ! 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 - - p15(pos+1) = -GxRho*(w_left*z_t(iin,jin) + w_right*z_t(iin,jin+1)) - - ! Pressure - do n=2,5 ; p15(pos+n) = p15(pos+n-1) + GxRho*0.25*dz_y(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) + if (present(inty_dpa)) then + !$OMP parallel do default(shared) private(jin,iin,hWght,hL,hR,iDenom,Ttl,Ttr,Tbl,Tbr,Stl,Str,Sbl,Sbr, & + !$OMP w_left,w_right,dz_y,pos,T15,S15,p15,r15,weight_t,weight_b,intz) + do J=Jsq,Jeq ; jin = j+joff + do i=HIO%isc,HIO%iec ; 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(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 + hR = (z_t(iin,jin+1) - z_b(iin,jin+1)) + dz_subroundoff + hWght = hWght * ( (hL-hR)/(hL+hR) )**2 + iDenom = 1./( hWght*(hR + hL) + hL*hR ) + Ttl = ( (hWght*hR)*T_t(iin,jin+1) + (hWght*hL + hR*hL)*T_t(iin,jin) ) * iDenom + Ttr = ( (hWght*hL)*T_t(iin,jin) + (hWght*hR + hR*hL)*T_t(iin,jin+1) ) * iDenom + Tbl = ( (hWght*hR)*T_b(iin,jin+1) + (hWght*hL + hR*hL)*T_b(iin,jin) ) * iDenom + Tbr = ( (hWght*hL)*T_b(iin,jin) + (hWght*hR + hR*hL)*T_b(iin,jin+1) ) * iDenom + Stl = ( (hWght*hR)*S_t(iin,jin+1) + (hWght*hL + hR*hL)*S_t(iin,jin) ) * iDenom + Str = ( (hWght*hL)*S_t(iin,jin) + (hWght*hR + hR*hL)*S_t(iin,jin+1) ) * iDenom + Sbl = ( (hWght*hR)*S_b(iin,jin+1) + (hWght*hL + hR*hL)*S_b(iin,jin) ) * iDenom + Sbr = ( (hWght*hL)*S_b(iin,jin) + (hWght*hR + hR*hL)*S_b(iin,jin+1) ) * iDenom + else + Ttl = T_t(iin,jin); Tbl = T_b(iin,jin); Ttr = T_t(iin,jin+1); Tbr = T_b(iin,jin+1) + Stl = S_t(iin,jin); Sbl = S_b(iin,jin); Str = S_t(iin,jin+1); Sbr = S_b(iin,jin+1) + endif + + do m=2,4 + w_left = 0.25*real(5-m) ; w_right = 1.0-w_left + dz_y(m,i) = w_left*(z_t(iin,jin) - z_b(iin,jin)) + w_right*(z_t(iin,jin+1) - z_b(iin,jin+1)) + + ! 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 + + p15(pos+1) = -GxRho*(w_left*z_t(iin,jin) + w_right*z_t(iin,jin+1)) + + ! Pressure + do n=2,5 ; p15(pos+n) = p15(pos+n-1) + GxRho*0.25*dz_y(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) + enddo enddo enddo - 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, rho_ref) - do i=HIO%isc,HIO%iec ; iin = i+ioff - intz(1) = dpa(i,j) ; intz(5) = dpa(i,j+1) - - ! 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_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))) + 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, rho_ref) + do i=HIO%isc,HIO%iec ; iin = i+ioff + intz(1) = dpa(i,j) ; intz(5) = dpa(i,j+1) + + ! 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_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))) + 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)) + & + 12.0*intz(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)) + & - 12.0*intz(3)) enddo - enddo ; endif + endif end subroutine int_density_dz_generic_plm ! ========================================================================== From 48310e3d61c2256f2b7f8686cbb0712a805f89a7 Mon Sep 17 00:00:00 2001 From: alperaltuntas Date: Thu, 23 Apr 2020 00:40:36 -0600 Subject: [PATCH 233/316] eliminate omp parallel open/close in to int_density_dz_generic_plm --- src/equation_of_state/MOM_EOS.F90 | 13 ++++++++----- 1 file changed, 8 insertions(+), 5 deletions(-) diff --git a/src/equation_of_state/MOM_EOS.F90 b/src/equation_of_state/MOM_EOS.F90 index c26317d3a9..fcc5cc1352 100644 --- a/src/equation_of_state/MOM_EOS.F90 +++ b/src/equation_of_state/MOM_EOS.F90 @@ -1271,7 +1271,11 @@ subroutine int_density_dz_generic_plm (T_t, T_b, S_t, S_b, z_t, z_b, rho_ref, & ! 1. Compute vertical integrals ! ============================= - !$OMP parallel do default(shared) private(jin,iin,dz,p5,S5,T5,r5,rho_anom) + !$OMP parallel default(shared) private(jin,iin,dz,p5,S5,T5,r5,rho_anom,hWght,hL,hR,iDenom,Ttl,Ttr, & + !$OMP Tbl,Tbr,Stl,Str,Sbl,Sbr,w_left,w_right,dz_x,dz_y,pos,T15,S15, & + !$OMP p15,r15,weight_t,weight_b,intz) + + !$OMP do do j=Jsq,Jeq+1 jin = j+joff do i = Isq,Ieq+1 ; iin = i+ioff @@ -1303,8 +1307,7 @@ 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 - !$OMP parallel do default(shared) private(jin,iin,hWght,hL,hR,iDenom,Ttl,Ttr,Tbl,Tbr,Stl,Str,Sbl,Sbr, & - !$OMP w_left,w_right,dz_x,pos,T15,S15,p15,r15,weight_t,weight_b,intz) + !$OMP do do j=HIO%jsc,HIO%jec ; jin = j+joff do I=Isq,Ieq ; iin = i+ioff ! Corner values of T and S @@ -1388,8 +1391,7 @@ subroutine int_density_dz_generic_plm (T_t, T_b, S_t, S_b, z_t, z_b, rho_ref, & ! 3. Compute horizontal integrals in the y direction ! ================================================== if (present(inty_dpa)) then - !$OMP parallel do default(shared) private(jin,iin,hWght,hL,hR,iDenom,Ttl,Ttr,Tbl,Tbr,Stl,Str,Sbl,Sbr, & - !$OMP w_left,w_right,dz_y,pos,T15,S15,p15,r15,weight_t,weight_b,intz) + !$OMP do do J=Jsq,Jeq ; jin = j+joff do i=HIO%isc,HIO%iec ; iin = i+ioff ! Corner values of T and S @@ -1467,6 +1469,7 @@ subroutine int_density_dz_generic_plm (T_t, T_b, S_t, S_b, z_t, z_b, rho_ref, & enddo enddo endif + !$OMP end parallel end subroutine int_density_dz_generic_plm ! ========================================================================== From 21c655c851bf18241af1a798311e85d4f518ae04 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 23 Apr 2020 18:44:22 -0400 Subject: [PATCH 234/316] +Make wave speed calcs more robust via new options Added new options to control the wave speed calculation. These are set with optional arguments to wave_speed_init, wave_speed_set_params, wave_speed and wave_speeds, which are set with the runtime parameters INTERNAL_WAVE_SPEED_TOL, INTERNAL_WAVE_SPEED_MIN, and INTERNAL_WAVE_SPEED_BETTER_EST. Also altered the internal scaling of velocity to make cascading underflows leading to NaNs less likely. By default all answers are bitwise identical, but there are three new runtime parameters and new optional arguments to 4 public interfaces. --- src/diagnostics/MOM_diagnostics.F90 | 17 + src/diagnostics/MOM_wave_speed.F90 | 478 +++++++++++++----- .../lateral/MOM_lateral_mixing_coeffs.F90 | 23 +- 3 files changed, 382 insertions(+), 136 deletions(-) diff --git a/src/diagnostics/MOM_diagnostics.F90 b/src/diagnostics/MOM_diagnostics.F90 index ca9ad28b62..77739f3ead 100644 --- a/src/diagnostics/MOM_diagnostics.F90 +++ b/src/diagnostics/MOM_diagnostics.F90 @@ -1451,6 +1451,10 @@ subroutine MOM_diagnostics_init(MIS, ADp, CDp, Time, G, GV, US, param_file, diag # include "version_variable.h" character(len=40) :: mdl = "MOM_diagnostics" ! This module's name. character(len=48) :: thickness_units, flux_units + real :: wave_speed_min ! A floor in the first mode speed below which 0 is returned [L T-1 ~> m s-1] + real :: wave_speed_tol ! The fractional tolerance for finding the wave speeds [nondim] + logical :: better_speed_est ! If true, use a more robust estimate of the first + ! mode wave speed as the starting point for iterations. logical :: use_temperature, adiabatic logical :: default_2018_answers, remap_answers_2018 integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB, nz, nkml, nkbl @@ -1483,6 +1487,16 @@ subroutine MOM_diagnostics_init(MIS, ADp, CDp, Time, G, GV, US, param_file, diag "The depth below which N2 is limited as monotonic for the "// & "purposes of calculating the equivalent barotropic wave speed.", & units='m', scale=US%m_to_Z, default=-1.) + call get_param(param_file, mdl, "INTERNAL_WAVE_SPEED_TOL", wave_speed_tol, & + "The fractional tolerance for finding the wave speeds.", & + units="nondim", default=0.001) + !### Set defaults so that wave_speed_min*wave_speed_tol >= 1e-9 m s-1 + call get_param(param_file, mdl, "INTERNAL_WAVE_SPEED_MIN", wave_speed_min, & + "A floor in the first mode speed below which 0 used instead.", & + units="m s-1", default=0.0, scale=US%m_s_to_L_T) + call get_param(param_file, mdl, "INTERNAL_WAVE_SPEED_BETTER_EST", better_speed_est, & + "If true, use a more robust estimate of the first mode wave speed as the "//& + "starting point for iterations.", default=.false.) !### Change the default. call get_param(param_file, mdl, "DEFAULT_2018_ANSWERS", default_2018_answers, & "This sets the default value for the various _2018_ANSWERS parameters.", & default=.true.) @@ -1701,6 +1715,9 @@ subroutine MOM_diagnostics_init(MIS, ADp, CDp, Time, G, GV, US, param_file, diag if ((CS%id_cg1>0) .or. (CS%id_Rd1>0) .or. (CS%id_cfl_cg1>0) .or. & (CS%id_cfl_cg1_x>0) .or. (CS%id_cfl_cg1_y>0) .or. & (CS%id_cg_ebt>0) .or. (CS%id_Rd_ebt>0) .or. (CS%id_p_ebt>0)) then + call wave_speed_init(CS%wave_speed_CSp, remap_answers_2018=remap_answers_2018, & + better_speed_est=better_speed_est, min_speed=wave_speed_min, & + wave_speed_tol=wave_speed_tol) call wave_speed_init(CS%wave_speed_CSp, remap_answers_2018=remap_answers_2018) call safe_alloc_ptr(CS%cg1,isd,ied,jsd,jed) if (CS%id_Rd1>0) call safe_alloc_ptr(CS%Rd1,isd,ied,jsd,jed) diff --git a/src/diagnostics/MOM_wave_speed.F90 b/src/diagnostics/MOM_wave_speed.F90 index c955c4eb95..65a23e0fa2 100644 --- a/src/diagnostics/MOM_wave_speed.F90 +++ b/src/diagnostics/MOM_wave_speed.F90 @@ -30,6 +30,8 @@ module MOM_wave_speed !! of the first baroclinic wave speed. !! This parameter controls the default behavior of wave_speed() which !! can be overridden by optional arguments. + logical :: better_cg1_est = .false. !< If true, use an improved estimate of the first mode + !! internal wave speed. 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 @@ -38,6 +40,9 @@ module MOM_wave_speed !! calculating the equivalent barotropic wave speed [Z ~> m]. !! This parameter controls the default behavior of wave_speed() which !! can be overridden by optional arguments. + real :: min_speed2 = 0. !< The minimum mode 1 internal wave speed squared [L2 T-2 ~> m2 s-2] + real :: wave_speed_tol = 0.001 !< The fractional tolerance with which to solve for the wave + !! speeds [nondim] type(remapping_CS) :: remapping_CS !< Used for vertical remapping when calculating equivalent barotropic !! mode structure. logical :: remap_answers_2018 = .true. !< If true, use the order of arithmetic and expressions that @@ -49,8 +54,8 @@ module MOM_wave_speed contains !> Calculates the wave speed of the first baroclinic mode. -subroutine wave_speed(h, tv, G, GV, US, cg1, CS, full_halos, use_ebt_mode, & - mono_N2_column_fraction, mono_N2_depth, modal_structure) +subroutine wave_speed(h, tv, G, GV, US, cg1, CS, full_halos, use_ebt_mode, mono_N2_column_fraction, & + mono_N2_depth, modal_structure, better_speed_est, min_speed, wave_speed_tol) type(ocean_grid_type), intent(in) :: G !< Ocean grid structure type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type @@ -59,18 +64,24 @@ subroutine wave_speed(h, tv, G, GV, US, cg1, CS, full_halos, use_ebt_mode, & type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamic variables real, dimension(SZI_(G),SZJ_(G)), intent(out) :: cg1 !< First mode internal wave speed [L T-1 ~> m s-1] type(wave_speed_CS), pointer :: CS !< Control structure for MOM_wave_speed - logical, optional, intent(in) :: full_halos !< If true, do the calculation + 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 + 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 + 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 + real, optional, intent(in) :: mono_N2_depth !< A depth below which N2 is limited as !! monotonic for the purposes of calculating vertical !! modal structure [Z ~> m]. real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & - optional, intent(out) :: modal_structure !< Normalized model structure [nondim] + optional, intent(out) :: modal_structure !< Normalized model structure [nondim] + logical, optional, intent(in) :: better_speed_est !< If true, use a more robust estimate of the first + !! mode speed as the starting point for iterations. + real, optional, intent(in) :: min_speed !< If present, set a floor in the first mode speed + !! below which 0 is returned [L T-1 ~> m s-1]. + real, optional, intent(in) :: wave_speed_tol !< The fractional tolerance for finding the + !! wave speeds [nondim] ! Local variables real, dimension(SZK_(G)+1) :: & @@ -79,6 +90,8 @@ subroutine wave_speed(h, tv, G, GV, US, cg1, CS, full_halos, use_ebt_mode, & pres, & ! Interface pressure [R L2 T-2 ~> Pa] T_int, & ! Temperature interpolated to interfaces [degC] S_int, & ! Salinity interpolated to interfaces [ppt] + H_top, & ! The distance of each filtered interface from the ocean surface [Z ~> m] + H_bot, & ! The distance of each filtered interface from the bottom [Z ~> m] gprime ! The reduced gravity across each interface [L2 Z-1 T-2 ~> m s-2]. real, dimension(SZK_(G)) :: & Igl, Igu, Igd ! The inverse of the reduced gravity across an interface times @@ -95,6 +108,7 @@ subroutine wave_speed(h, tv, G, GV, US, cg1, CS, full_halos, use_ebt_mode, & Sc, & ! A column of layer salinites after convective istabilities are removed [ppt] Rc, & ! A column of layer densities after convective istabilities are removed [R ~> kg m-3] Hc_H ! Hc(:) rescaled from Z to thickness units [H ~> m or kg m-2] + real :: I_Htot ! The inverse of the total filtered thicknesses [Z ~> m] real :: det, ddet, detKm1, detKm2, ddetKm1, ddetKm2 real :: lam ! The eigenvalue [T2 L-2 ~> s m-1] real :: dlam ! The change in estimates of the eigenvalue [T2 L-2 ~> s m-1] @@ -108,22 +122,28 @@ subroutine wave_speed(h, tv, G, GV, US, cg1, CS, full_halos, use_ebt_mode, & HxS_here, & ! A layer integrated salinity [ppt Z ~> ppt m] HxR_here ! A layer integrated density [R Z ~> kg m-2] real :: speed2_tot ! overestimate of the mode-1 speed squared [L2 T-2 ~> m2 s-2] + real :: cg1_min2 ! A floor in the squared first mode speed below which 0 is returned [L2 T-2 ~> m2 s-2] real :: I_Hnew ! The inverse of a new layer thickness [Z-1 ~> m-1] - real :: drxh_sum ! The sum of density diffrences across interfaces times thicknesses [R Z ~> kg m-2] + real :: drxh_sum ! The sum of density differences across interfaces times thicknesses [R Z ~> kg m-2] real :: L2_to_Z2 ! A scaling factor squared from units of lateral distances to depths [Z2 L-2 ~> 1]. - real, parameter :: tol1 = 0.0001, tol2 = 0.001 real, pointer, dimension(:,:,:) :: T => NULL(), S => NULL() - real :: g_Rho0 ! G_Earth/Rho0 [L2 T-2 Z-1 R-1 ~> m4 s-2 kg-1]. + real :: g_Rho0 ! G_Earth/Rho0 [L2 T-2 Z-1 R-1 ~> m4 s-2 kg-1]. real :: c2_scale ! A scaling factor for wave speeds to help control the growth of the determinant ! and its derivative with lam between rows of the Thomas algorithm solver. The ! exact value should not matter for the final result if it is an even power of 2. + real :: tol_Hfrac ! Layers that together are smaller than this fraction of + ! the total water column can be merged for efficiency. + real :: tol_solve ! The fractional tolerance with which to solve for the wave speeds [nondim] + real :: tol_merge ! The fractional change in estimated wave speed that is allowed + ! when deciding to merge layers in the calculation [nondim] real :: rescale, I_rescale - integer :: kf(SZI_(G)) + integer :: kf(SZI_(G)) ! The number of active layers after filtering. integer, parameter :: max_itt = 10 real :: lam_it(max_itt), det_it(max_itt), ddet_it(max_itt) - logical :: use_EOS ! If true, density is calculated from T & S using an - ! equation of state. - integer :: kc + logical :: use_EOS ! If true, density is calculated from T & S using an equation of state. + logical :: better_est ! If true, use an improved estimate of the first mode internal wave speed. + logical :: merge ! If true, merge the current layer with the one above. + integer :: kc ! The number of layers in the column after merging integer :: i, j, k, k2, itt, is, ie, js, je, nz real :: hw, sum_hc real :: gp ! A limited local copy of gprime [L2 Z-1 T-2 ~> m s-2] @@ -162,22 +182,38 @@ subroutine wave_speed(h, tv, G, GV, US, cg1, CS, full_halos, use_ebt_mode, & Z_to_pres = GV%Z_to_H * (GV%H_to_RZ * GV%g_Earth) use_EOS = associated(tv%eqn_of_state) + better_est = CS%better_cg1_est ; if (present(better_speed_est)) better_est = better_speed_est + + if (better_est) then + tol_solve = CS%wave_speed_tol ; if (present(wave_speed_tol)) tol_solve = wave_speed_tol + tol_Hfrac = 0.1*tol_solve ; tol_merge = tol_solve / real(nz) + else + tol_solve = 0.001 ; tol_Hfrac = 0.0001 ; tol_merge = 0.001 + endif + + ! The rescaling below can control the growth of the determinant provided that + ! (tol_merge*cg1_min2/c2_scale > I_rescale). For default values, this suggests a stable lower + ! bound on min_speed of sqrt(nz/(tol_solve*rescale)) or 3e2/1024**2 = 2.9e-4 m/s for 90 layers. + ! The upper bound on the rate of increase in the determinant is g'H/c2_scale < rescale or in the + ! worst possible oceanic case of g'H < 0.5*10m/s2*1e4m = 5.e4 m2/s2 < 1024**2*c2_scale, suggesting + ! that c2_scale can safely be set to 1/(16*1024**2), which would decrease the stable floor on + ! min_speed to ~6.9e-8 m/s for 90 layers or 2.33e-7 m/s for 1000 layers. + cg1_min2 = CS%min_speed2 ; if (present(min_speed)) cg1_min2 = min_speed**2 rescale = 1024.0**4 ; I_rescale = 1.0/rescale - ! The following two lines give identical results: - ! c2_scale = 16.0 * US%m_s_to_L_T**2 - c2_scale = US%m_s_to_L_T**2 + c2_scale = US%m_s_to_L_T**2 / 4096.0**2 ! Other powers of 2 give identical results. - min_h_frac = tol1 / real(nz) + min_h_frac = tol_Hfrac / real(nz) !$OMP parallel do default(none) shared(is,ie,js,je,nz,h,G,GV,US,min_h_frac,use_EOS,T,S,tv,& !$OMP calc_modal_structure,l_use_ebt_mode,modal_structure, & !$OMP l_mono_N2_column_fraction,l_mono_N2_depth,CS, & -!$OMP Z_to_pres,cg1,g_Rho0,rescale,I_rescale,L2_to_Z2,c2_scale) & +!$OMP Z_to_pres,cg1,g_Rho0,rescale,I_rescale,L2_to_Z2, & +!$OMP better_est,cg1_min2,tol_merge,tol_solve,c2_scale) & !$OMP private(htot,hmin,kf,H_here,HxT_here,HxS_here,HxR_here, & -!$OMP Hf,Tf,Sf,Rf,pres,T_int,S_int,drho_dT, & -!$OMP drho_dS,drxh_sum,kc,Hc,Hc_H,Tc,Sc,I_Hnew,gprime,& +!$OMP Hf,Tf,Sf,Rf,pres,T_int,S_int,drho_dT,drho_dS, & +!$OMP drxh_sum,kc,Hc,Hc_H,tC,sc,I_Hnew,gprime,& !$OMP Rc,speed2_tot,Igl,Igu,Igd,lam0,lam,lam_it,dlam, & !$OMP mode_struct,sum_hc,N2min,gp,hw, & -!$OMP ms_min,ms_max,ms_sq, & +!$OMP ms_min,ms_max,ms_sq,H_top,H_bot,I_Htot,merge, & !$OMP det,ddet,detKm1,ddetKm1,detKm2,ddetKm2,det_it,ddet_it) do j=js,je ! First merge very thin layers with the one above (or below if they are @@ -232,52 +268,85 @@ subroutine wave_speed(h, tv, G, GV, US, cg1, CS, full_halos, use_ebt_mode, & endif ; enddo endif - ! From this point, we can work on individual columns without causing memory - ! to have page faults. + ! From this point, we can work on individual columns without causing memory to have page faults. do i=is,ie ; if (G%mask2dT(i,j) > 0.5) then if (use_EOS) then - pres(1) = 0.0 - do k=2,kf(i) - pres(k) = pres(k-1) + Z_to_pres*Hf(k-1,i) - T_int(k) = 0.5*(Tf(k,i)+Tf(k-1,i)) - S_int(k) = 0.5*(Sf(k,i)+Sf(k-1,i)) + pres(1) = 0.0 ; H_top(1) = 0.0 + do K=2,kf(i) + pres(K) = pres(K-1) + Z_to_pres*Hf(k-1,i) + T_int(K) = 0.5*(Tf(k,i)+Tf(k-1,i)) + S_int(K) = 0.5*(Sf(k,i)+Sf(k-1,i)) + H_top(K) = H_top(K-1) + Hf(k-1,i) enddo call calculate_density_derivs(T_int, S_int, pres, drho_dT, drho_dS, & tv%eqn_of_state, (/2,kf(i)/) ) - ! Sum the reduced gravities to find out how small a density difference - ! is negligibly small. + ! Sum the reduced gravities to find out how small a density difference is negligibly small. drxh_sum = 0.0 - do k=2,kf(i) - drxh_sum = drxh_sum + 0.5*(Hf(k-1,i)+Hf(k,i)) * & - max(0.0,drho_dT(k)*(Tf(k,i)-Tf(k-1,i)) + & - drho_dS(k)*(Sf(k,i)-Sf(k-1,i))) - enddo + if (better_est) then + ! This is an estimate that is correct for the non-EBT mode for 2 or 3 layers, or for + ! clusters of massless layers at interfaces that can be grouped into 2 or 3 layers. + ! For a uniform stratification and a huge number of layers uniformly distributed in + ! density, this estimate is too large (as is desired) by a factor of pi^2/6 ~= 1.64. + if (H_top(kf(i)) > 0.0) then + I_Htot = 1.0 / (H_top(kf(i)) + Hf(kf(i),i)) ! = 1.0 / (H_top(K) + H_bot(K)) for all K. + H_bot(kf(i)+1) = 0.0 + do K=kf(i),2,-1 + H_bot(K) = H_bot(K+1) + Hf(k,i) + drxh_sum = drxh_sum + ((H_top(K) * H_bot(K)) * I_Htot) * & + max(0.0, drho_dT(K)*(Tf(k,i)-Tf(k-1,i)) + drho_dS(K)*(Sf(k,i)-Sf(k-1,i))) + enddo + endif + else + ! This estimate is problematic in that it goes like 1/nz for a large number of layers, + ! but it is an overestimate (as desired) for a small number of layers, by at a factor + ! of (H1+H2)**2/(H1*H2) >= 4 for two thick layers. + do K=2,kf(i) + drxh_sum = drxh_sum + 0.5*(Hf(k-1,i)+Hf(k,i)) * & + max(0.0, drho_dT(K)*(Tf(k,i)-Tf(k-1,i)) + drho_dS(K)*(Sf(k,i)-Sf(k-1,i))) + enddo + endif else drxh_sum = 0.0 - do k=2,kf(i) - drxh_sum = drxh_sum + 0.5*(Hf(k-1,i)+Hf(k,i)) * & - max(0.0,Rf(k,i)-Rf(k-1,i)) - enddo - endif - - if (calc_modal_structure) then - mode_struct(:) = 0. + if (better_est) then + H_top(1) = 0.0 + do K=2,kf(i) ; H_top(K) = H_top(K-1) + Hf(k-1,i) ; enddo + if (H_top(kf(i)) > 0.0) then + I_Htot = 1.0 / (H_top(kf(i)) + Hf(kf(i),i)) ! = 1.0 / (H_top(K) + H_bot(K)) for all K. + H_bot(kf(i)+1) = 0.0 + do K=kf(i),2,-1 + H_bot(K) = H_bot(K+1) + Hf(k,i) + drxh_sum = drxh_sum + ((H_top(K) * H_bot(K)) * I_Htot) * max(0.0,Rf(k,i)-Rf(k-1,i)) + enddo + endif + else + do K=2,kf(i) + drxh_sum = drxh_sum + 0.5*(Hf(k-1,i)+Hf(k,i)) * max(0.0,Rf(k,i)-Rf(k-1,i)) + enddo + endif endif - ! Find gprime across each internal interface, taking care of convective - ! instabilities by merging layers. - if (drxh_sum <= 0.0) then + ! Find gprime across each internal interface, taking care of convective instabilities by + ! merging layers. If the estimated wave speed is too small, simply return zero. + if (g_Rho0 * drxh_sum <= cg1_min2) then cg1(i,j) = 0.0 + if (present(modal_structure)) modal_structure(i,j,:) = 0. else ! Merge layers to eliminate convective instabilities or exceedingly - ! small reduced gravities. + ! small reduced gravities. Merging layers reduces the estimated wave speed by + ! (rho(2)-rho(1))*h(1)*h(2) / H_tot. if (use_EOS) then kc = 1 Hc(1) = Hf(1,i) ; Tc(1) = Tf(1,i) ; Sc(1) = Sf(1,i) do k=2,kf(i) - if ((drho_dT(k)*(Tf(k,i)-Tc(kc)) + drho_dS(k)*(Sf(k,i)-Sc(kc))) * & - (Hc(kc) + Hf(k,i)) < 2.0 * tol2*drxh_sum) then + if (better_est) then + merge = ((drho_dT(K)*(Tf(k,i)-Tc(kc)) + drho_dS(K)*(Sf(k,i)-Sc(kc))) * & + ((Hc(kc) * Hf(k,i))*I_Htot) < 2.0 * tol_merge*drxh_sum) + else + merge = ((drho_dT(K)*(Tf(k,i)-Tc(kc)) + drho_dS(K)*(Sf(k,i)-Sc(kc))) * & + (Hc(kc) + Hf(k,i)) < 2.0 * tol_merge*drxh_sum) + endif + if (merge) then ! Merge this layer with the one above and backtrack. I_Hnew = 1.0 / (Hc(kc) + Hf(k,i)) Tc(kc) = (Hc(kc)*Tc(kc) + Hf(k,i)*Tf(k,i)) * I_Hnew @@ -286,9 +355,15 @@ subroutine wave_speed(h, tv, G, GV, US, cg1, CS, full_halos, use_ebt_mode, & ! Backtrack to remove any convective instabilities above... Note ! that the tolerance is a factor of two larger, to avoid limit how ! far back we go. - do k2=kc,2,-1 - if ((drho_dT(k2)*(Tc(k2)-Tc(k2-1)) + drho_dS(k2)*(Sc(k2)-Sc(k2-1))) * & - (Hc(k2) + Hc(k2-1)) < tol2*drxh_sum) then + do K2=kc,2,-1 + if (better_est) then + merge = ((drho_dT(K2)*(Tc(k2)-Tc(k2-1)) + drho_dS(K2)*(Sc(k2)-Sc(k2-1))) * & + ((Hc(k2) * Hc(k2-1))*I_Htot) < tol_merge*drxh_sum) + else + merge = ((drho_dT(K2)*(Tc(k2)-Tc(k2-1)) + drho_dS(K2)*(Sc(k2)-Sc(k2-1))) * & + (Hc(k2) + Hc(k2-1)) < tol_merge*drxh_sum) + endif + if (merge) then ! Merge the two bottommost layers. At this point kc = k2. I_Hnew = 1.0 / (Hc(kc) + Hc(kc-1)) Tc(kc-1) = (Hc(kc)*Tc(kc) + Hc(kc-1)*Tc(kc-1)) * I_Hnew @@ -300,21 +375,25 @@ subroutine wave_speed(h, tv, G, GV, US, cg1, CS, full_halos, use_ebt_mode, & else ! Add a new layer to the column. kc = kc + 1 - drho_dS(kc) = drho_dS(k) ; drho_dT(kc) = drho_dT(k) + drho_dS(Kc) = drho_dS(K) ; drho_dT(Kc) = drho_dT(K) Tc(kc) = Tf(k,i) ; Sc(kc) = Sf(k,i) ; Hc(kc) = Hf(k,i) endif enddo ! At this point there are kc layers and the gprimes should be positive. - do k=2,kc ! Revisit this if non-Boussinesq. - gprime(k) = g_Rho0 * (drho_dT(k)*(Tc(k)-Tc(k-1)) + & - drho_dS(k)*(Sc(k)-Sc(k-1))) + do K=2,kc ! Revisit this if non-Boussinesq. + gprime(K) = g_Rho0 * (drho_dT(K)*(Tc(k)-Tc(k-1)) + drho_dS(K)*(Sc(k)-Sc(k-1))) enddo else ! .not.use_EOS ! Do the same with density directly... kc = 1 Hc(1) = Hf(1,i) ; Rc(1) = Rf(1,i) do k=2,kf(i) - if ((Rf(k,i) - Rc(kc)) * (Hc(kc) + Hf(k,i)) < 2.0*tol2*drxh_sum) then + if (better_est) then + merge = ((Rf(k,i) - Rc(kc)) * ((Hc(kc) * Hf(k,i))*I_Htot) < 2.0*tol_merge*drxh_sum) + else + merge = ((Rf(k,i) - Rc(kc)) * (Hc(kc) + Hf(k,i)) < 2.0*tol_merge*drxh_sum) + endif + if (merge) then ! Merge this layer with the one above and backtrack. Rc(kc) = (Hc(kc)*Rc(kc) + Hf(k,i)*Rf(k,i)) / (Hc(kc) + Hf(k,i)) Hc(kc) = (Hc(kc) + Hf(k,i)) @@ -322,7 +401,12 @@ subroutine wave_speed(h, tv, G, GV, US, cg1, CS, full_halos, use_ebt_mode, & ! that the tolerance is a factor of two larger, to avoid limit how ! far back we go. do k2=kc,2,-1 - if ((Rc(k2)-Rc(k2-1)) * (Hc(k2)+Hc(k2-1)) < tol2*drxh_sum) then + if (better_est) then + merge = ((Rc(k2)-Rc(k2-1)) * ((Hc(k2) * Hc(k2-1))*I_Htot) < tol_merge*drxh_sum) + else + merge = ((Rc(k2)-Rc(k2-1)) * (Hc(k2)+Hc(k2-1)) < tol_merge*drxh_sum) + endif + if (merge) then ! Merge the two bottommost layers. At this point kc = k2. Rc(kc-1) = (Hc(kc)*Rc(kc) + Hc(kc-1)*Rc(kc-1)) / (Hc(kc) + Hc(kc-1)) Hc(kc-1) = (Hc(kc) + Hc(kc-1)) @@ -336,8 +420,8 @@ subroutine wave_speed(h, tv, G, GV, US, cg1, CS, full_halos, use_ebt_mode, & endif enddo ! At this point there are kc layers and the gprimes should be positive. - do k=2,kc ! Revisit this if non-Boussinesq. - gprime(k) = g_Rho0 * (Rc(k)-Rc(k-1)) + do K=2,kc ! Revisit this if non-Boussinesq. + gprime(K) = g_Rho0 * (Rc(k)-Rc(k-1)) enddo endif ! use_EOS @@ -346,6 +430,13 @@ subroutine wave_speed(h, tv, G, GV, US, cg1, CS, full_halos, use_ebt_mode, & ! non-leading diagonals of the tridiagonal matrix. if (kc >= 2) then speed2_tot = 0.0 + if (better_est) then + H_top(1) = 0.0 ; H_bot(kc+1) = 0.0 + do K=2,kc+1 ; H_top(K) = H_top(K-1) + Hc(k-1) ; enddo + do K=kc,2,-1 ; H_bot(K) = H_bot(K+1) + Hc(k) ; enddo + I_Htot = 0.0 ; if (H_top(kc+1) > 0.0) I_Htot = 1.0 / H_top(kc+1) + endif + if (l_use_ebt_mode) then Igu(1) = 0. ! Neumann condition for pressure modes sum_hc = Hc(1) @@ -366,23 +457,33 @@ subroutine wave_speed(h, tv, G, GV, US, cg1, CS, full_halos, use_ebt_mode, & endif Igu(k) = 1.0/(gp*Hc(k)) Igl(k-1) = 1.0/(gp*Hc(k-1)) - speed2_tot = speed2_tot + gprime(k)*(Hc(k-1)+Hc(k))*0.707 sum_hc = sum_hc + Hc(k) + if (better_est) then + ! Estimate that the ebt_mode is sqrt(2) times the speed of the flat bottom modes. + speed2_tot = speed2_tot + 2.0 * gprime(K)*((H_top(K) * H_bot(K)) * I_Htot) + else ! The ebt_mode wave should be faster than the flat-bottom mode, so 0.707 should be > 1? + speed2_tot = speed2_tot + gprime(K)*(Hc(k-1)+Hc(k))*0.707 + endif enddo !Igl(kc) = 0. ! Neumann condition for pressure modes Igl(kc) = 2.*Igu(kc) ! Dirichlet condition for pressure modes else ! .not. l_use_ebt_mode do K=2,kc Igl(K) = 1.0/(gprime(K)*Hc(k)) ; Igu(K) = 1.0/(gprime(K)*Hc(k-1)) - speed2_tot = speed2_tot + gprime(k)*(Hc(k-1)+Hc(k)) + if (better_est) then + speed2_tot = speed2_tot + gprime(K)*((H_top(K) * H_bot(K)) * I_Htot) + else + speed2_tot = speed2_tot + gprime(K)*(Hc(k-1)+Hc(k)) + endif enddo endif if (calc_modal_structure) then + mode_struct(:) = 0. mode_struct(1:kc) = 1. ! Uniform flow, first guess endif - ! Overestimate the speed to start with. + ! Under estimate the first eigenvalue (overestimate the speed) to start with. if (calc_modal_structure) then lam0 = 0.5 / speed2_tot ; lam = lam0 else @@ -417,7 +518,7 @@ subroutine wave_speed(h, tv, G, GV, US, cg1, CS, full_halos, use_ebt_mode, & ! 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 ... | + ! | 0 igu(4) b(4)-lam igl(4) 0 ... | ! which is consistent if the eigenvalue problem is for vertical velocity modes. detKm1 = 1.0 ; ddetKm1 = 0.0 det = (Igu(2) + Igl(2) - lam) ; ddet = -1.0 @@ -479,7 +580,7 @@ subroutine wave_speed(h, tv, G, GV, US, cg1, CS, full_halos, use_ebt_mode, & endif endif - if (abs(dlam) < tol2*lam) exit + if (abs(dlam) < tol_solve*lam) exit enddo cg1(i,j) = 0.0 @@ -567,17 +668,24 @@ subroutine tdma6(n, a, b, c, lam, y) end subroutine tdma6 !> Calculates the wave speeds for the first few barolinic modes. -subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, full_halos) - type(ocean_grid_type), intent(in) :: G !< Ocean grid structure +subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, full_halos, better_speed_est, & + min_speed, wave_speed_tol) + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer thickness [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer thickness [H ~> m or kg m-2] type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamic variables integer, intent(in) :: nmodes !< Number of modes real, dimension(G%isd:G%ied,G%jsd:G%jed,nmodes), intent(out) :: cn !< Waves speeds [L T-1 ~> m s-1] type(wave_speed_CS), optional, 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) :: better_speed_est !< If true, use a more robust estimate of the first + !! mode speed as the starting point for iterations. + real, optional, intent(in) :: min_speed !< If present, set a floor in the first mode speed + !! below which 0 is returned [L T-1 ~> m s-1]. + real, optional, intent(in) :: wave_speed_tol !< The fractional tolerance for finding the + !! wave speeds [nondim] ! Local variables real, dimension(SZK_(G)+1) :: & dRho_dT, & ! Partial derivative of density with temperature [R degC-1 ~> kg m-3 degC-1] @@ -585,6 +693,8 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, full_halos) pres, & ! Interface pressure [R L2 T-2 ~> Pa] T_int, & ! Temperature interpolated to interfaces [degC] S_int, & ! Salinity interpolated to interfaces [ppt] + H_top, & ! The distance of each filtered interface from the ocean surface [Z ~> m] + H_bot, & ! The distance of each filtered interface from the bottom [Z ~> m] gprime ! The reduced gravity across each interface [L2 Z-1 T-2 ~> m s-2]. real, dimension(SZK_(G)) :: & Igl, Igu ! The inverse of the reduced gravity across an interface times @@ -603,8 +713,12 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, full_halos) Tc, & ! A column of layer temperatures after convective istabilities are removed [degC] Sc, & ! A column of layer salinites after convective istabilities are removed [ppt] Rc ! A column of layer densities after convective istabilities are removed [R ~> kg m-3] + real :: I_Htot ! The inverse of the total filtered thicknesses [Z ~> m] real :: c1_thresh ! if c1 is below this value, don't bother calculating ! cn values for higher modes [L T-1 ~> m s-1] + real :: c2_scale ! A scaling factor for wave speeds to help control the growth of the determinant + ! and its derivative with lam between rows of the Thomas algorithm solver. The + ! exact value should not matter for the final result if it is an even power of 2. real :: det, ddet ! determinant & its derivative of eigen system real :: lam_1 ! approximate mode-1 eigenvalue [T2 L-2 ~> s2 m-2] real :: lam_n ! approximate mode-n eigenvalue [T2 L-2 ~> s2 m-2] @@ -631,16 +745,23 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, full_halos) HxR_here ! A layer integrated density [R Z ~> kg m-2] real :: speed2_tot ! overestimate of the mode-1 speed squared [L2 T-2 ~> m2 s-2] real :: speed2_min ! minimum mode speed (squared) to consider in root searching [L2 T-2 ~> m2 s-2] + real :: cg1_min2 ! A floor in the squared first mode speed below which 0 is returned [L2 T-2 ~> m2 s-2] real, parameter :: reduct_factor = 0.5 ! factor used in setting speed2_min [nondim] real :: I_Hnew ! The inverse of a new layer thickness [Z-1 ~> m-1] - real :: drxh_sum ! The sum of density diffrences across interfaces times thicknesses [R Z ~> kg m-2] - real, parameter :: tol1 = 0.0001, tol2 = 0.001 + real :: drxh_sum ! The sum of density differences across interfaces times thicknesses [R Z ~> kg m-2] real, pointer, dimension(:,:,:) :: T => NULL(), S => NULL() - real :: g_Rho0 ! G_Earth/Rho0 [L2 T-2 Z-1 R-1 ~> m4 s-2 kg-1]. - integer :: kf(SZI_(G)) + real :: g_Rho0 ! G_Earth/Rho0 [L2 T-2 Z-1 R-1 ~> m4 s-2 kg-1]. + real :: tol_Hfrac ! Layers that together are smaller than this fraction of + ! the total water column can be merged for efficiency. + real :: tol_solve ! The fractional tolerance with which to solve for the wave speeds [nondim]. + real :: tol_merge ! The fractional change in estimated wave speed that is allowed + ! when deciding to merge layers in the calculation [nondim] + integer :: kf(SZI_(G)) ! The number of active layers after filtering. integer, parameter :: max_itt = 10 logical :: use_EOS ! If true, density is calculated from T & S using the equation of state. + logical :: better_est ! If true, use an improved estimate of the first mode internal wave speed. + logical :: merge ! If true, merge the current layer with the one above. real, dimension(SZK_(G)+1) :: z_int ! real, dimension(SZK_(G)+1) :: N2 ! The local squared buoyancy frequency [T-2 ~> s-2] integer :: nsub ! number of subintervals used for root finding @@ -648,8 +769,8 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, full_halos) ! maximum number of times to subdivide interval ! for root finding (# intervals = 2**sub_it_max) logical :: sub_rootfound ! if true, subdivision has located root - integer :: kc, nrows - integer :: sub, sub_it + integer :: kc ! The number of layers in the column after merging + integer :: nrows, sub, sub_it integer :: i, j, k, k2, itt, is, ie, js, je, nz, row, iint, m, ig, jg is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke @@ -669,8 +790,21 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, full_halos) ! Simplifying the following could change answers at roundoff. Z_to_pres = GV%Z_to_H * (GV%H_to_RZ * GV%g_Earth) c1_thresh = 0.01*US%m_s_to_L_T + c2_scale = US%m_s_to_L_T**2 / 4096.0**2 ! Other powers of 2 give identical results. + + better_est = .false. ; if (present(CS)) better_est = CS%better_cg1_est + if (present(better_speed_est)) better_est = better_speed_est + if (better_est) then + tol_solve = 0.001 ; if (present(CS)) tol_solve = CS%wave_speed_tol + if (present(wave_speed_tol)) tol_solve = wave_speed_tol + tol_Hfrac = 0.1*tol_solve ; tol_merge = tol_solve / real(nz) + else + tol_Hfrac = 0.0001 ; tol_solve = 0.001 ; tol_merge = 0.001 + endif + cg1_min2 = 0.0 ; if (present(CS)) cg1_min2 = CS%min_speed2 + if (present(min_speed)) cg1_min2 = min_speed**2 - min_h_frac = tol1 / real(nz) + min_h_frac = tol_Hfrac / real(nz) !$OMP parallel do default(private) shared(is,ie,js,je,nz,h,G,GV,US,min_h_frac,use_EOS,T,S, & !$OMP Z_to_pres,tv,cn,g_Rho0,nmodes) do j=js,je @@ -726,48 +860,85 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, full_halos) endif ; enddo endif - ! From this point, we can work on individual columns without causing memory - ! to have page faults. + ! From this point, we can work on individual columns without causing memory to have page faults. do i=is,ie if (G%mask2dT(i,j) > 0.5) then if (use_EOS) then - pres(1) = 0.0 - do k=2,kf(i) - pres(k) = pres(k-1) + Z_to_pres*Hf(k-1,i) - T_int(k) = 0.5*(Tf(k,i)+Tf(k-1,i)) - S_int(k) = 0.5*(Sf(k,i)+Sf(k-1,i)) + pres(1) = 0.0 ; H_top(1) = 0.0 + do K=2,kf(i) + pres(K) = pres(K-1) + Z_to_pres*Hf(k-1,i) + T_int(K) = 0.5*(Tf(k,i)+Tf(k-1,i)) + S_int(K) = 0.5*(Sf(k,i)+Sf(k-1,i)) + H_top(K) = H_top(K-1) + Hf(k-1,i) enddo call calculate_density_derivs(T_int, S_int, pres, drho_dT, drho_dS, & tv%eqn_of_state, (/2,kf(i)/) ) - ! Sum the reduced gravities to find out how small a density difference - ! is negligibly small. + ! Sum the reduced gravities to find out how small a density difference is negligibly small. drxh_sum = 0.0 - do k=2,kf(i) - drxh_sum = drxh_sum + 0.5*(Hf(k-1,i)+Hf(k,i)) * & - max(0.0,drho_dT(k)*(Tf(k,i)-Tf(k-1,i)) + & - drho_dS(k)*(Sf(k,i)-Sf(k-1,i))) - enddo + if (better_est) then + ! This is an estimate that is correct for the non-EBT mode for 2 or 3 layers, or for + ! clusters of massless layers at interfaces that can be grouped into 2 or 3 layers. + ! For a uniform stratification and a huge number of layers uniformly distributed in + ! density, this estimate is too large (as is desired) by a factor of pi^2/6 ~= 1.64. + if (H_top(kf(i)) > 0.0) then + I_Htot = 1.0 / (H_top(kf(i)) + Hf(kf(i),i)) ! = 1.0 / (H_top(K) + H_bot(K)) for all K. + H_bot(kf(i)+1) = 0.0 + do K=kf(i),2,-1 + H_bot(K) = H_bot(K+1) + Hf(k,i) + drxh_sum = drxh_sum + ((H_top(K) * H_bot(K)) * I_Htot) * & + max(0.0, drho_dT(K)*(Tf(k,i)-Tf(k-1,i)) + drho_dS(K)*(Sf(k,i)-Sf(k-1,i))) + enddo + endif + else + ! This estimate is problematic in that it goes like 1/nz for a large number of layers, + ! but it is an overestimate (as desired) for a small number of layers, by at a factor + ! of (H1+H2)**2/(H1*H2) >= 4 for two thick layers. + do K=2,kf(i) + drxh_sum = drxh_sum + 0.5*(Hf(k-1,i)+Hf(k,i)) * & + max(0.0, drho_dT(K)*(Tf(k,i)-Tf(k-1,i)) + drho_dS(K)*(Sf(k,i)-Sf(k-1,i))) + enddo + endif else drxh_sum = 0.0 - do k=2,kf(i) - drxh_sum = drxh_sum + 0.5*(Hf(k-1,i)+Hf(k,i)) * & - max(0.0,Rf(k,i)-Rf(k-1,i)) - enddo + if (better_est) then + H_top(1) = 0.0 + do K=2,kf(i) ; H_top(K) = H_top(K-1) + Hf(k-1,i) ; enddo + if (H_top(kf(i)) > 0.0) then + I_Htot = 1.0 / (H_top(kf(i)) + Hf(kf(i),i)) ! = 1.0 / (H_top(K) + H_bot(K)) for all K. + H_bot(kf(i)+1) = 0.0 + do K=kf(i),2,-1 + H_bot(K) = H_bot(K+1) + Hf(k,i) + drxh_sum = drxh_sum + ((H_top(K) * H_bot(K)) * I_Htot) * max(0.0,Rf(k,i)-Rf(k-1,i)) + enddo + endif + else + do K=2,kf(i) + drxh_sum = drxh_sum + 0.5*(Hf(k-1,i)+Hf(k,i)) * max(0.0,Rf(k,i)-Rf(k-1,i)) + enddo + endif endif - ! Find gprime across each internal interface, taking care of convective - ! instabilities by merging layers. - if (drxh_sum <= 0.0) then + + ! Find gprime across each internal interface, taking care of convective + ! instabilities by merging layers. + if (g_Rho0 * drxh_sum <= cg1_min2) then cn(i,j,:) = 0.0 else ! Merge layers to eliminate convective instabilities or exceedingly - ! small reduced gravities. + ! small reduced gravities. Merging layers reduces the estimated wave speed by + ! (rho(2)-rho(1))*h(1)*h(2) / H_tot. if (use_EOS) then kc = 1 Hc(1) = Hf(1,i) ; Tc(1) = Tf(1,i) ; Sc(1) = Sf(1,i) do k=2,kf(i) - if ((drho_dT(k)*(Tf(k,i)-Tc(kc)) + drho_dS(k)*(Sf(k,i)-Sc(kc))) * & - (Hc(kc) + Hf(k,i)) < 2.0 * tol2*drxh_sum) then + if (better_est) then + merge = ((drho_dT(K)*(Tf(k,i)-Tc(kc)) + drho_dS(K)*(Sf(k,i)-Sc(kc))) * & + ((Hc(kc) * Hf(k,i))*I_Htot) < 2.0 * tol_merge*drxh_sum) + else + merge = ((drho_dT(K)*(Tf(k,i)-Tc(kc)) + drho_dS(K)*(Sf(k,i)-Sc(kc))) * & + (Hc(kc) + Hf(k,i)) < 2.0 * tol_merge*drxh_sum) + endif + if (merge) then ! Merge this layer with the one above and backtrack. I_Hnew = 1.0 / (Hc(kc) + Hf(k,i)) Tc(kc) = (Hc(kc)*Tc(kc) + Hf(k,i)*Tf(k,i)) * I_Hnew @@ -776,9 +947,15 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, full_halos) ! Backtrack to remove any convective instabilities above... Note ! that the tolerance is a factor of two larger, to avoid limit how ! far back we go. - do k2=kc,2,-1 - if ((drho_dT(k2)*(Tc(k2)-Tc(k2-1)) + drho_dS(k2)*(Sc(k2)-Sc(k2-1))) * & - (Hc(k2) + Hc(k2-1)) < tol2*drxh_sum) then + do K2=kc,2,-1 + if (better_est) then + merge = ((drho_dT(K2)*(Tc(k2)-Tc(k2-1)) + drho_dS(K2)*(Sc(k2)-Sc(k2-1))) * & + ((Hc(k2) * Hc(k2-1))*I_Htot) < tol_merge*drxh_sum) + else + merge = ((drho_dT(K2)*(Tc(k2)-Tc(k2-1)) + drho_dS(K2)*(Sc(k2)-Sc(k2-1))) * & + (Hc(k2) + Hc(k2-1)) < tol_merge*drxh_sum) + endif + if (merge) then ! Merge the two bottommost layers. At this point kc = k2. I_Hnew = 1.0 / (Hc(kc) + Hc(kc-1)) Tc(kc-1) = (Hc(kc)*Tc(kc) + Hc(kc-1)*Tc(kc-1)) * I_Hnew @@ -790,21 +967,25 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, full_halos) else ! Add a new layer to the column. kc = kc + 1 - drho_dS(kc) = drho_dS(k) ; drho_dT(kc) = drho_dT(k) + drho_dS(Kc) = drho_dS(K) ; drho_dT(Kc) = drho_dT(K) Tc(kc) = Tf(k,i) ; Sc(kc) = Sf(k,i) ; Hc(kc) = Hf(k,i) endif enddo ! At this point there are kc layers and the gprimes should be positive. - do k=2,kc ! Revisit this if non-Boussinesq. - gprime(k) = g_Rho0 * (drho_dT(k)*(Tc(k)-Tc(k-1)) + & - drho_dS(k)*(Sc(k)-Sc(k-1))) + do K=2,kc ! Revisit this if non-Boussinesq. + gprime(K) = g_Rho0 * (drho_dT(K)*(Tc(k)-Tc(k-1)) + drho_dS(K)*(Sc(k)-Sc(k-1))) enddo else ! .not.use_EOS ! Do the same with density directly... kc = 1 Hc(1) = Hf(1,i) ; Rc(1) = Rf(1,i) do k=2,kf(i) - if ((Rf(k,i) - Rc(kc)) * (Hc(kc) + Hf(k,i)) < 2.0*tol2*drxh_sum) then + if (better_est) then + merge = ((Rf(k,i) - Rc(kc)) * ((Hc(kc) * Hf(k,i))*I_Htot) < 2.0 * tol_merge*drxh_sum) + else + merge = ((Rf(k,i) - Rc(kc)) * (Hc(kc) + Hf(k,i)) < 2.0*tol_merge*drxh_sum) + endif + if (merge) then ! Merge this layer with the one above and backtrack. Rc(kc) = (Hc(kc)*Rc(kc) + Hf(k,i)*Rf(k,i)) / (Hc(kc) + Hf(k,i)) Hc(kc) = (Hc(kc) + Hf(k,i)) @@ -812,7 +993,12 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, full_halos) ! that the tolerance is a factor of two larger, to avoid limit how ! far back we go. do k2=kc,2,-1 - if ((Rc(k2)-Rc(k2-1)) * (Hc(k2)+Hc(k2-1)) < tol2*drxh_sum) then + if (better_est) then + merge = ((Rc(k2)-Rc(k2-1)) * ((Hc(kc) * Hc(k2-1))*I_Htot) < tol_merge*drxh_sum) + else + merge = ((Rc(k2)-Rc(k2-1)) * (Hc(k2)+Hc(k2-1)) < tol_merge*drxh_sum) + endif + if (merge) then ! Merge the two bottommost layers. At this point kc = k2. Rc(kc-1) = (Hc(kc)*Rc(kc) + Hc(kc-1)*Rc(kc-1)) / (Hc(kc) + Hc(kc-1)) Hc(kc-1) = (Hc(kc) + Hc(kc-1)) @@ -826,8 +1012,8 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, full_halos) endif enddo ! At this point there are kc layers and the gprimes should be positive. - do k=2,kc ! Revisit this if non-Boussinesq. - gprime(k) = g_Rho0 * (Rc(k)-Rc(k-1)) + do K=2,kc ! Revisit this if non-Boussinesq. + gprime(K) = g_Rho0 * (Rc(k)-Rc(k-1)) enddo endif ! use_EOS @@ -840,13 +1026,24 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, full_halos) z_int(1) = 0.0 ! initialize speed2_tot speed2_tot = 0.0 + if (better_est) then + H_top(1) = 0.0 ; H_bot(kc+1) = 0.0 + do K=2,kc+1 ; H_top(K) = H_top(K-1) + Hc(k-1) ; enddo + do K=kc,2,-1 ; H_bot(K) = H_bot(K+1) + Hc(k) ; enddo + I_Htot = 0.0 ; if (H_top(kc+1) > 0.0) I_Htot = 1.0 / H_top(kc+1) + endif + ! Calculate Igu, Igl, depth, and N2 at each interior interface ! [excludes surface (K=1) and bottom (K=kc+1)] do K=2,kc Igl(K) = 1.0/(gprime(K)*Hc(k)) ; Igu(K) = 1.0/(gprime(K)*Hc(k-1)) z_int(K) = z_int(K-1) + Hc(k-1) ! N2(K) = US%L_to_Z**2*gprime(K)/(0.5*(Hc(k)+Hc(k-1))) - speed2_tot = speed2_tot + gprime(K)*(Hc(k-1)+Hc(k)) + if (better_est) then + speed2_tot = speed2_tot + gprime(K)*((H_top(K) * H_bot(K)) * I_Htot) + else + speed2_tot = speed2_tot + gprime(K)*(Hc(k-1)+Hc(k)) + endif enddo ! Set stratification for surface and bottom (setting equal to nearest interface for now) ! N2(1) = N2(2) ; N2(kc+1) = N2(kc) @@ -878,14 +1075,14 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, full_halos) ! Total number of rows in the matrix = number of interior interfaces nrows = kc-1 - ! Under estimate the first eigenvalue to start with. + ! Under estimate the first eigenvalue (overestimate the speed) to start with. lam_1 = 1.0 / speed2_tot - ! Find the first eigenvalue + ! Find the first eigen value do itt=1,max_itt ! calculate the determinant of (A-lam_1*I) call tridiag_det(a_diag(1:nrows),b_diag(1:nrows),c_diag(1:nrows), & - nrows,lam_1,det,ddet, row_scale=US%m_s_to_L_T**2) + nrows,lam_1,det,ddet, row_scale=c2_scale) ! Use Newton's method iteration to find a new estimate of lam_1 !det = det_it(itt) ; ddet = ddet_it(itt) if ((ddet >= 0.0) .or. (-det > -0.5*lam_1*ddet)) then @@ -896,7 +1093,7 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, full_halos) else ! Newton's method is OK. dlam = - det / ddet lam_1 = lam_1 + dlam - if (abs(dlam) < tol2*lam_1) then + if (abs(dlam) < tol_solve*lam_1) then ! calculate 1st mode speed if (lam_1 > 0.0) cn(i,j,1) = 1.0 / sqrt(lam_1) exit @@ -904,12 +1101,12 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, full_halos) endif enddo - ! Find other eigenvalues if c1 is of significant magnitude, > cn_thresh + ! Find other eigen values if c1 is of significant magnitude, > cn_thresh nrootsfound = 0 ! number of extra roots found (not including 1st root) if (nmodes>1 .and. kc>=nmodes+1 .and. cn(i,j,1)>c1_thresh) then - ! Set the the range to look for the other desired eigenvalues + ! Set the the range to look for the other desired eigen values ! set min value just greater than the 1st root (found above) - lamMin = lam_1*(1.0 + tol2) + lamMin = lam_1*(1.0 + tol_solve) ! set max value based on a low guess at wavespeed for highest mode speed2_min = (reduct_factor*cn(i,j,1)/real(nmodes))**2 lamMax = 1.0 / speed2_min @@ -923,13 +1120,13 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, full_halos) ! find det_l of first interval (det at left endpoint) call tridiag_det(a_diag(1:nrows),b_diag(1:nrows),c_diag(1:nrows), & - nrows,lamMin,det_l,ddet_l, row_scale=US%m_s_to_L_T**2) + nrows,lamMin,det_l,ddet_l, row_scale=c2_scale) ! move interval window looking for zero-crossings************************ do iint=1,numint xr = lamMin + lamInc * iint xl = xr - lamInc call tridiag_det(a_diag(1:nrows),b_diag(1:nrows),c_diag(1:nrows), & - nrows,xr,det_r,ddet_r, row_scale=US%m_s_to_L_T**2) + nrows,xr,det_r,ddet_r, row_scale=c2_scale) if (det_l*det_r < 0.0) then ! if function changes sign if (det_l*ddet_l < 0.0) then ! if function at left is headed to zero nrootsfound = nrootsfound + 1 @@ -950,7 +1147,7 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, full_halos) do sub=1,nsub-1,2 ! only check odds; sub = 1; 1,3; 1,3,5,7;... xl_sub = xl + lamInc/(nsub)*sub call tridiag_det(a_diag(1:nrows),b_diag(1:nrows),c_diag(1:nrows), & - nrows,xl_sub,det_sub,ddet_sub, row_scale=US%m_s_to_L_T**2) + nrows,xl_sub,det_sub,ddet_sub, row_scale=c2_scale) if (det_sub*det_r < 0.0) then ! if function changes sign if (det_sub*ddet_sub < 0.0) then ! if function at left is headed to zero sub_rootfound = .true. @@ -993,11 +1190,11 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, full_halos) do itt=1,max_itt ! calculate the determinant of (A-lam_n*I) call tridiag_det(a_diag(1:nrows),b_diag(1:nrows),c_diag(1:nrows), & - nrows,lam_n,det,ddet, row_scale=US%m_s_to_L_T**2) + nrows,lam_n,det,ddet, row_scale=c2_scale) ! Use Newton's method to find a new estimate of lam_n dlam = - det / ddet lam_n = lam_n + dlam - if (abs(dlam) < tol2*lam_1) then + if (abs(dlam) < tol_solve*lam_1) then ! calculate nth mode speed if (lam_n > 0.0) cn(i,j,m+1) = 1.0 / sqrt(lam_n) exit @@ -1036,7 +1233,7 @@ subroutine tridiag_det(a, b, c, nrows, lam, det_out, ddet_out, row_scale) ! Local variables real, dimension(nrows) :: det ! value of recursion function real, dimension(nrows) :: ddet ! value of recursion function for derivative - real, parameter:: rescale = 1024.0**4 ! max value of determinant allowed before rescaling + real, parameter :: rescale = 1024.0**4 ! max value of determinant allowed before rescaling real :: rscl real :: I_rescale ! inverse of rescale integer :: n ! row (layer interface) index @@ -1068,7 +1265,8 @@ subroutine tridiag_det(a, b, c, nrows, lam, det_out, ddet_out, row_scale) end subroutine tridiag_det !> Initialize control structure for MOM_wave_speed -subroutine wave_speed_init(CS, use_ebt_mode, mono_N2_column_fraction, mono_N2_depth, remap_answers_2018) +subroutine wave_speed_init(CS, use_ebt_mode, mono_N2_column_fraction, mono_N2_depth, remap_answers_2018, & + better_speed_est, min_speed, wave_speed_tol) 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. @@ -1079,9 +1277,14 @@ subroutine wave_speed_init(CS, use_ebt_mode, mono_N2_column_fraction, mono_N2_de !! as monotonic for the purposes of calculating the !! vertical modal structure [Z ~> m]. logical, optional, intent(in) :: remap_answers_2018 !< If true, use the order of arithmetic and expressions - !! that recover the remapping answers from 2018. Otherwise - !! use more robust but mathematically equivalent expressions. - + !! that recover the remapping answers from 2018. Otherwise + !! use more robust but mathematically equivalent expressions. + logical, optional, intent(in) :: better_speed_est !< If true, use a more robust estimate of the first + !! mode speed as the starting point for iterations. + real, optional, intent(in) :: min_speed !< If present, set a floor in the first mode speed + !! below which 0 is returned [L T-1 ~> m s-1]. + real, optional, intent(in) :: wave_speed_tol !< The fractional tolerance for finding the + !! wave speeds [nondim] ! This include declares and sets the variable "version". # include "version_variable.h" @@ -1096,7 +1299,8 @@ subroutine wave_speed_init(CS, use_ebt_mode, mono_N2_column_fraction, mono_N2_de ! Write all relevant parameters to the model log. call log_version(mdl, version) - call wave_speed_set_param(CS, use_ebt_mode=use_ebt_mode, mono_N2_column_fraction=mono_N2_column_fraction) + call wave_speed_set_param(CS, use_ebt_mode=use_ebt_mode, mono_N2_column_fraction=mono_N2_column_fraction, & + better_speed_est=better_speed_est, min_speed=min_speed, wave_speed_tol=wave_speed_tol) call initialize_remapping(CS%remapping_CS, 'PLM', boundary_extrapolation=.false., & answers_2018=CS%remap_answers_2018) @@ -1104,7 +1308,8 @@ subroutine wave_speed_init(CS, use_ebt_mode, mono_N2_column_fraction, mono_N2_de end subroutine wave_speed_init !> Sets internal parameters for MOM_wave_speed -subroutine wave_speed_set_param(CS, use_ebt_mode, mono_N2_column_fraction, mono_N2_depth, remap_answers_2018) +subroutine wave_speed_set_param(CS, use_ebt_mode, mono_N2_column_fraction, mono_N2_depth, remap_answers_2018, & + better_speed_est, min_speed, wave_speed_tol) 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. @@ -1117,6 +1322,12 @@ subroutine wave_speed_set_param(CS, use_ebt_mode, mono_N2_column_fraction, mono_ logical, optional, intent(in) :: remap_answers_2018 !< If true, use the order of arithmetic and expressions !! that recover the remapping answers from 2018. Otherwise !! use more robust but mathematically equivalent expressions. + logical, optional, intent(in) :: better_speed_est !< If true, use a more robust estimate of the first + !! mode speed as the starting point for iterations. + real, optional, intent(in) :: min_speed !< If present, set a floor in the first mode speed + !! below which 0 is returned [L T-1 ~> m s-1]. + real, optional, intent(in) :: wave_speed_tol !< The fractional tolerance for finding the + !! wave speeds [nondim] if (.not.associated(CS)) call MOM_error(FATAL, & "wave_speed_set_param called with an associated control structure.") @@ -1125,6 +1336,9 @@ subroutine wave_speed_set_param(CS, use_ebt_mode, mono_N2_column_fraction, mono_ if (present(mono_N2_column_fraction)) CS%mono_N2_column_fraction = mono_N2_column_fraction if (present(mono_N2_depth)) CS%mono_N2_depth = mono_N2_depth if (present(remap_answers_2018)) CS%remap_answers_2018 = remap_answers_2018 + if (present(better_speed_est)) CS%better_cg1_est = better_speed_est + if (present(min_speed)) CS%min_speed2 = min_speed**2 + if (present(wave_speed_tol)) CS%wave_speed_tol = wave_speed_tol end subroutine wave_speed_set_param @@ -1151,7 +1365,7 @@ end subroutine wave_speed_set_param !! !! Here !! \verbatim -!! Igl(k) = 1.0/(gprime(k)*h(k)) ; Igu(k) = 1.0/(gprime(k)*h(k-1)) +!! Igl(k) = 1.0/(gprime(K)*h(k)) ; Igu(k) = 1.0/(gprime(K)*h(k-1)) !! \endverbatim !! !! Alternately, these same eigenvalues can be found from the second smallest diff --git a/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 b/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 index e5e699ebee..37e549f3f1 100644 --- a/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 +++ b/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 @@ -602,8 +602,7 @@ subroutine calc_Visbeck_coeffs(h, slope_x, slope_y, N2_u, N2_v, G, GV, US, CS) endif if (CS%debug) then - call uvchksum("calc_Visbeck_coeffs slope_[xy]", slope_x, slope_y, G%HI, & - haloshift=1) + call uvchksum("calc_Visbeck_coeffs slope_[xy]", slope_x, slope_y, G%HI, haloshift=1) call uvchksum("calc_Visbeck_coeffs N2_u, N2_v", N2_u, N2_v, G%HI, & scale=US%s_to_T**2, scalar_pair=.true.) call uvchksum("calc_Visbeck_coeffs SN_[uv]", CS%SN_u, CS%SN_v, G%HI, & @@ -926,8 +925,12 @@ subroutine VarMix_init(Time, G, GV, US, param_file, diag, CS) real :: Leith_Lap_const ! The non-dimensional coefficient in the Leith viscosity real :: grid_sp_u2, grid_sp_v2 ! Intermediate quantities for Leith metrics [L2 ~> m2] real :: grid_sp_u3, grid_sp_v3 ! Intermediate quantities for Leith metrics [L3 ~> m3] + real :: wave_speed_min ! A floor in the first mode speed below which 0 is returned [L T-1 ~> m s-1] + real :: wave_speed_tol ! The fractional tolerance for finding the wave speeds [nondim] + logical :: better_speed_est ! If true, use a more robust estimate of the first + ! mode wave speed as the starting point for iterations. ! This include declares and sets the variable "version". -#include "version_variable.h" +# include "version_variable.h" character(len=40) :: mdl = "MOM_lateral_mixing_coeffs" ! This module's name. integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, i, j integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB @@ -1250,8 +1253,20 @@ subroutine VarMix_init(Time, G, GV, US, param_file, diag, CS) "If true, use the order of arithmetic and expressions that recover the "//& "answers from the end of 2018. Otherwise, use updated and more robust "//& "forms of the same expressions.", default=default_2018_answers) + call get_param(param_file, mdl, "INTERNAL_WAVE_SPEED_TOL", wave_speed_tol, & + "The fractional tolerance for finding the wave speeds.", & + units="nondim", default=0.001) + !### Set defaults so that wave_speed_min*wave_speed_tol >= 1e-9 m s-1 + call get_param(param_file, mdl, "INTERNAL_WAVE_SPEED_MIN", wave_speed_min, & + "A floor in the first mode speed below which 0 used instead.", & + units="m s-1", default=0.0, scale=US%m_s_to_L_T) + call get_param(param_file, mdl, "INTERNAL_WAVE_SPEED_BETTER_EST", better_speed_est, & + "If true, use a more robust estimate of the first mode wave speed as the "//& + "starting point for iterations.", default=.false.) !### Change the default. call wave_speed_init(CS%wave_speed_CSp, use_ebt_mode=CS%Resoln_use_ebt, & - mono_N2_depth=N2_filter_depth, remap_answers_2018=remap_answers_2018) + mono_N2_depth=N2_filter_depth, remap_answers_2018=remap_answers_2018, & + better_speed_est=better_speed_est, min_speed=wave_speed_min, & + wave_speed_tol=wave_speed_tol) endif ! Leith parameters From 760e41b40774b8c0c8ef0925b3aa13aa85d2e797 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Tue, 28 Apr 2020 15:33:45 -0400 Subject: [PATCH 235/316] +Added reproducing_sum_EFP and EFP_sum_across_PEs Added new interfaces reproducing_sum_EFP and EFP_sum_across_PEs, along with new only_on_PE optional arguments to reproducing_sum to allow for deferred global sums. All answers are bitwise identical, but the new options and interfaces should allow for more efficient code configurations. --- src/framework/MOM_coms.F90 | 309 ++++++++++++++++++++++++++----------- 1 file changed, 219 insertions(+), 90 deletions(-) diff --git a/src/framework/MOM_coms.F90 b/src/framework/MOM_coms.F90 index b80ac56baa..dd367b3c4b 100644 --- a/src/framework/MOM_coms.F90 +++ b/src/framework/MOM_coms.F90 @@ -10,20 +10,19 @@ module MOM_coms use mpp_mod, only : PE_here => mpp_pe, root_PE => mpp_root_pe, num_PEs => mpp_npes use mpp_mod, only : Set_PElist => mpp_set_current_pelist, Get_PElist => mpp_get_current_pelist use mpp_mod, only : broadcast => mpp_broadcast -use mpp_mod, only : sum_across_PEs => mpp_sum, min_across_PEs => mpp_min -use mpp_mod, only : max_across_PEs => mpp_max +use mpp_mod, only : sum_across_PEs => mpp_sum, max_across_PEs => mpp_max, min_across_PEs => mpp_min implicit none ; private public :: PE_here, root_PE, num_PEs, MOM_infra_init, MOM_infra_end public :: broadcast, sum_across_PEs, min_across_PEs, max_across_PEs -public :: reproducing_sum, EFP_list_sum_across_PEs +public :: reproducing_sum, reproducing_sum_EFP, EFP_sum_across_PEs, EFP_list_sum_across_PEs public :: EFP_plus, EFP_minus, EFP_to_real, real_to_EFP, EFP_real_diff public :: operator(+), operator(-), assignment(=) public :: query_EFP_overflow_error, reset_EFP_overflow_error public :: Set_PElist, Get_PElist -! This module provides interfaces to the non-domain-oriented communication -! subroutines. + +! This module provides interfaces to the non-domain-oriented communication subroutines. integer(kind=8), parameter :: prec=2_8**46 !< The precision of each integer. real, parameter :: r_prec=2.0**46 !< A real version of prec. @@ -50,11 +49,22 @@ module MOM_coms logical :: NaN_error = .false. !< This becomes true if a NaN is encountered. logical :: debug = .false. !< Making this true enables debugging output. -!> Find an accurate and order-invariant sum of distributed 2d or 3d fields +!> Find an accurate and order-invariant sum of a distributed 2d or 3d field interface reproducing_sum module procedure reproducing_sum_2d, reproducing_sum_3d end interface reproducing_sum +!> Find an accurate and order-invariant sum of a distributed 2d field, returning the result +!! in the form of an extended fixed point value that can be converted back with EFP_to_real. +interface reproducing_sum_EFP + module procedure reproducing_EFP_sum_2d +end interface reproducing_sum_EFP + +!> Sum a value or 1-d array of values across processors, returning the sums in place +interface EFP_sum_across_PEs + module procedure EFP_list_sum_across_PEs, EFP_val_sum_across_PEs +end interface EFP_sum_across_PEs + !> The Extended Fixed Point (EFP) type provides a public interface for doing sums !! and taking differences with this type. !! @@ -75,12 +85,12 @@ module MOM_coms 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, +!! order-invariant sum of distributed 2-D arrays that reproduces across domain decomposition, with +!! the result returned as an extended fixed point type that can be converted back to a real number +!! using EFP_to_real. 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 !< The array to be summed +function reproducing_EFP_sum_2d(array, isr, ier, jsr, jer, overflow_check, err, only_on_PE) result(EFP_sum) + 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 @@ -89,9 +99,6 @@ function reproducing_sum_2d(array, isr, ier, jsr, jer, EFP_sum, reproducing, & !! 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 @@ -99,7 +106,9 @@ function reproducing_sum_2d(array, isr, ier, jsr, jer, EFP_sum, reproducing, & integer, optional, intent(out) :: err !< If present, return an error code instead of !! triggering any fatal errors directly from !! this routine. - real :: sum !< Result + logical, optional, intent(in) :: only_on_PE !< If present and true, do not do the sum + !! across processors, only reporting the local sum + type(EFP_type) :: EFP_sum !< The result in extended fixed point format ! This subroutine uses a conversion to an integer representation ! of real numbers to give order-invariant sums that will reproduce @@ -107,9 +116,9 @@ function reproducing_sum_2d(array, isr, ier, jsr, jer, EFP_sum, reproducing, & integer(kind=8), dimension(ni) :: ints_sum integer(kind=8) :: ival, prec_error - real :: rsum(1), rs + real :: rs real :: max_mag_term - logical :: repro, over_check + logical :: over_check, do_sum_across_PEs character(len=256) :: mesg integer :: i, j, n, is, ie, js, je, sgn @@ -121,94 +130,166 @@ function reproducing_sum_2d(array, isr, ier, jsr, jer, EFP_sum, reproducing, & is = 1 ; ie = size(array,1) ; js = 1 ; je = size(array,2 ) if (present(isr)) then - if (isr < is) call MOM_error(FATAL, & - "Value of isr too small in reproducing_sum_2d.") + if (isr < is) call MOM_error(FATAL, "Value of isr too small in reproducing_EFP_sum_2d.") is = isr endif if (present(ier)) then - if (ier > ie) call MOM_error(FATAL, & - "Value of ier too large in reproducing_sum_2d.") + if (ier > ie) call MOM_error(FATAL, "Value of ier too large in reproducing_EFP_sum_2d.") ie = ier endif if (present(jsr)) then - if (jsr < js) call MOM_error(FATAL, & - "Value of jsr too small in reproducing_sum_2d.") + if (jsr < js) call MOM_error(FATAL, "Value of jsr too small in reproducing_EFP_sum_2d.") js = jsr endif if (present(jer)) then - if (jer > je) call MOM_error(FATAL, & - "Value of jer too large in reproducing_sum_2d.") + if (jer > je) call MOM_error(FATAL, "Value of jer too large in reproducing_EFP_sum_2d.") je = jer endif - repro = .true. ; if (present(reproducing)) repro = reproducing over_check = .true. ; if (present(overflow_check)) over_check = overflow_check + do_sum_across_PEs = .true. ; if (present(only_on_PE)) do_sum_across_PEs = .not.only_on_PE - if (repro) then - overflow_error = .false. ; NaN_error = .false. ; max_mag_term = 0.0 - ints_sum(:) = 0 - if (over_check) then - if ((je+1-js)*(ie+1-is) < max_count_prec) then - do j=js,je ; do i=is,ie + overflow_error = .false. ; NaN_error = .false. ; max_mag_term = 0.0 + ints_sum(:) = 0 + 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) + 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) - 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) - 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) - enddo ; enddo - endif + call carry_overflow(ints_sum, prec_error) + enddo else do j=js,je ; do i=is,ie - sgn = 1 ; if (array(i,j)<0.0) sgn = -1 - rs = abs(array(i,j)) - do n=1,ni - ival = int(rs*I_pr(n), 8) - rs = rs - ival*pr(n) - ints_sum(n) = ints_sum(n) + sgn*ival - enddo + call increment_ints(ints_sum, real_to_ints(array(i,j), prec_error), & + prec_error) enddo ; enddo - call carry_overflow(ints_sum, prec_error) endif + else + do j=js,je ; do i=is,ie + sgn = 1 ; if (array(i,j)<0.0) sgn = -1 + rs = abs(array(i,j)) + do n=1,ni + ival = int(rs*I_pr(n), 8) + rs = rs - ival*pr(n) + ints_sum(n) = ints_sum(n) + sgn*ival + enddo + enddo ; enddo + call carry_overflow(ints_sum, prec_error) + endif - if (present(err)) then - err = 0 - if (overflow_error) & - err = err+2 - if (NaN_error) & - err = err+4 - if (err > 0) then ; do n=1,ni ; ints_sum(n) = 0 ; enddo ; endif - else - if (NaN_error) then - call MOM_error(FATAL, "NaN in input field of reproducing_sum(_2d).") - endif - if (abs(max_mag_term) >= prec_error*pr(1)) then - write(mesg, '(ES13.5)') max_mag_term - call MOM_error(FATAL,"Overflow in reproducing_sum(_2d) conversion of "//trim(mesg)) - endif - if (overflow_error) then - call MOM_error(FATAL, "Overflow in reproducing_sum(_2d).") - endif + if (present(err)) then + err = 0 + if (overflow_error) & + err = err+2 + if (NaN_error) & + err = err+4 + if (err > 0) then ; do n=1,ni ; ints_sum(n) = 0 ; enddo ; endif + else + if (NaN_error) then + call MOM_error(FATAL, "NaN in input field of reproducing_EFP_sum(_2d).") + endif + if (abs(max_mag_term) >= prec_error*pr(1)) then + write(mesg, '(ES13.5)') max_mag_term + call MOM_error(FATAL,"Overflow in reproducing_EFP_sum(_2d) conversion of "//trim(mesg)) endif + if (overflow_error) then + call MOM_error(FATAL, "Overflow in reproducing_EFP_sum(_2d).") + endif + endif - call sum_across_PEs(ints_sum, ni) + if (do_sum_across_PEs) call sum_across_PEs(ints_sum, ni) - call regularize_ints(ints_sum) - sum = ints_to_real(ints_sum) + call regularize_ints(ints_sum) + + EFP_sum%v(:) = ints_sum(:) + +end function reproducing_EFP_sum_2d + +!> 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, only_on_PE) result(sum) + 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. + logical, optional, intent(in) :: only_on_PE !< If present and true, do not do the sum + !! across processors, only reporting the local sum + real :: sum !< Result + + ! This subroutine uses a conversion to an integer representation + ! of real numbers to give order-invariant sums that will reproduce + ! across PE count. This idea comes from R. Hallberg and A. Adcroft. + + integer(kind=8), dimension(ni) :: ints_sum + integer(kind=8) :: prec_error + real :: rsum(1), rs + logical :: repro, do_sum_across_PEs + character(len=256) :: mesg + type(EFP_type) :: EFP_val ! An extended fixed point version of the sum + integer :: i, j, n, is, ie, js, je + + if (num_PEs() > max_count_prec) call MOM_error(FATAL, & + "reproducing_sum: Too many processors are being used for the value of "//& + "prec. Reduce prec to (2^63-1)/num_PEs.") + + prec_error = (2_8**62 + (2_8**62 - 1)) / num_PEs() + + is = 1 ; ie = size(array,1) ; js = 1 ; je = size(array,2 ) + if (present(isr)) then + if (isr < is) call MOM_error(FATAL, "Value of isr too small in reproducing_sum_2d.") + is = isr + endif + if (present(ier)) then + if (ier > ie) call MOM_error(FATAL, "Value of ier too large in reproducing_sum_2d.") + ie = ier + endif + if (present(jsr)) then + if (jsr < js) call MOM_error(FATAL, "Value of jsr too small in reproducing_sum_2d.") + js = jsr + endif + if (present(jer)) then + if (jer > je) call MOM_error(FATAL, "Value of jer too large in reproducing_sum_2d.") + je = jer + endif + + repro = .true. ; if (present(reproducing)) repro = reproducing + do_sum_across_PEs = .true. ; if (present(only_on_PE)) do_sum_across_PEs = .not.only_on_PE + + if (repro) then + EFP_val = reproducing_EFP_sum_2d(array, isr, ier, jsr, jer, overflow_check, err, only_on_PE) + sum = ints_to_real(EFP_val%v) + if (present(EFP_sum)) EFP_sum = EFP_val + if (debug) ints_sum(:) = EFP_sum%v(:) else rsum(1) = 0.0 do j=js,je ; do i=is,ie rsum(1) = rsum(1) + array(i,j) enddo ; enddo - call sum_across_PEs(rsum,1) + if (do_sum_across_PEs) call sum_across_PEs(rsum,1) sum = rsum(1) if (present(err)) then ; err = 0 ; endif @@ -225,10 +306,9 @@ function reproducing_sum_2d(array, isr, ier, jsr, jer, EFP_sum, reproducing, & endif endif endif + if (present(EFP_sum)) EFP_sum%v(:) = ints_sum(:) endif - if (present(EFP_sum)) EFP_sum%v(:) = ints_sum(:) - if (debug) then write(mesg,'("2d RS: ", ES24.16, 6 Z17.16)') sum, ints_sum(1:ni) call MOM_mesg(mesg, 3) @@ -240,7 +320,7 @@ end function reproducing_sum_2d !! 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) & +function reproducing_sum_3d(array, isr, ier, jsr, jer, sums, EFP_sum, err, only_on_PE) & result(sum) real, dimension(:,:,:), intent(in) :: array !< The array to be summed integer, optional, intent(in) :: isr !< The starting i-index of the sum, noting @@ -256,6 +336,8 @@ function reproducing_sum_3d(array, isr, ier, jsr, jer, sums, EFP_sum, err) & integer, optional, intent(out) :: err !< If present, return an error code instead of !! triggering any fatal errors directly from !! this routine. + logical, optional, intent(in) :: only_on_PE !< If present and true, do not do the sum + !! across processors, only reporting the local sum real :: sum !< Result ! This subroutine uses a conversion to an integer representation @@ -267,6 +349,7 @@ function reproducing_sum_3d(array, isr, ier, jsr, jer, sums, EFP_sum, err) & integer(kind=8), dimension(ni,size(array,3)) :: ints_sums integer(kind=8) :: prec_error character(len=256) :: mesg + logical :: do_sum_across_PEs integer :: i, j, k, is, ie, js, je, ke, isz, jsz, n if (num_PEs() > max_count_prec) call MOM_error(FATAL, & @@ -278,27 +361,25 @@ function reproducing_sum_3d(array, isr, ier, jsr, jer, sums, EFP_sum, err) & is = 1 ; ie = size(array,1) ; js = 1 ; je = size(array,2) ; ke = size(array,3) if (present(isr)) then - if (isr < is) call MOM_error(FATAL, & - "Value of isr too small in reproducing_sum(_3d).") + if (isr < is) call MOM_error(FATAL, "Value of isr too small in reproducing_sum(_3d).") is = isr endif if (present(ier)) then - if (ier > ie) call MOM_error(FATAL, & - "Value of ier too large in reproducing_sum(_3d).") + if (ier > ie) call MOM_error(FATAL, "Value of ier too large in reproducing_sum(_3d).") ie = ier endif if (present(jsr)) then - if (jsr < js) call MOM_error(FATAL, & - "Value of jsr too small in reproducing_sum(_3d).") + if (jsr < js) call MOM_error(FATAL, "Value of jsr too small in reproducing_sum(_3d).") js = jsr endif if (present(jer)) then - if (jer > je) call MOM_error(FATAL, & - "Value of jer too large in reproducing_sum(_3d).") + if (jer > je) call MOM_error(FATAL, "Value of jer too large in reproducing_sum(_3d).") je = jer endif jsz = je+1-js; isz = ie+1-is + do_sum_across_PEs = .true. ; if (present(only_on_PE)) do_sum_across_PEs = .not.only_on_PE + if (present(sums)) then if (size(sums) > ke) call MOM_error(FATAL, "Sums is smaller than "//& "the vertical extent of array in reproducing_sum(_3d).") @@ -339,7 +420,7 @@ function reproducing_sum_3d(array, isr, ier, jsr, jer, sums, EFP_sum, err) & if (overflow_error) call MOM_error(FATAL, "Overflow in reproducing_sum(_3d).") endif - call sum_across_PEs(ints_sums(:,1:ke), ni*ke) + if (do_sum_across_PEs) call sum_across_PEs(ints_sums(:,1:ke), ni*ke) sum = 0.0 do k=1,ke @@ -397,7 +478,7 @@ function reproducing_sum_3d(array, isr, ier, jsr, jer, sums, EFP_sum, err) & if (overflow_error) call MOM_error(FATAL, "Overflow in reproducing_sum(_3d).") endif - call sum_across_PEs(ints_sum, ni) + if (do_sum_across_PEs) call sum_across_PEs(ints_sum, ni) call regularize_ints(ints_sum) sum = ints_to_real(ints_sum) @@ -700,7 +781,7 @@ subroutine EFP_list_sum_across_PEs(EFPs, nval, errors) !! 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 + 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. @@ -742,6 +823,54 @@ subroutine EFP_list_sum_across_PEs(EFPs, nval, errors) end subroutine EFP_list_sum_across_PEs +!> This subroutine does a sum across PEs of an EFP variable, +!! returning the sums in place, with all overflows carried. +subroutine EFP_val_sum_across_PEs(EFP, error) + type(EFP_type), intent(inout) :: EFP !< The extended fixed point numbers + !! being summed across PEs. + logical, optional, intent(out) :: error !< An error flag for this sum + + ! This subroutine does a sum across PEs of a list of EFP variables, + ! returning the sums in place, with all overflows carried. + + integer(kind=8), dimension(ni) :: ints + integer(kind=8) :: prec_error + logical :: error_found + character(len=256) :: mesg + integer :: n + + if (num_PEs() > max_count_prec) call MOM_error(FATAL, & + "reproducing_sum: Too many processors are being used for the value of "//& + "prec. Reduce prec to (2^63-1)/num_PEs.") + + prec_error = (2_8**62 + (2_8**62 - 1)) / num_PEs() + ! overflow_error is an overflow error flag for the whole module. + overflow_error = .false. ; error_found = .false. + + do n=1,ni ; ints(n) = EFP%v(n) ; enddo + + call sum_across_PEs(ints(:), ni) + + if (present(error)) error = .false. + + overflow_error = .false. + call carry_overflow(ints(:), prec_error) + do n=1,ni ; EFP%v(n) = ints(n) ; enddo + if (present(error)) error = overflow_error + if (overflow_error) then + write (mesg,'("EFP_val_sum_across_PEs error val was ",ES12.6, ", prec_error = ",ES12.6)') & + EFP_to_real(EFP), real(prec_error) + call MOM_error(WARNING, mesg) + endif + error_found = error_found .or. overflow_error + + if (error_found .and. .not.(present(error))) then + call MOM_error(FATAL, "Overflow in EFP_val_sum_across_PEs.") + endif + +end subroutine EFP_val_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 From 4a9650fa1e82c686ad73d49e781fd9feeba2193d Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Tue, 28 Apr 2020 15:34:26 -0400 Subject: [PATCH 236/316] ROTATE_INDEX, INDEX_TURNS moved to debug params The index rotation flags were incorrectly handled as model parameters, rather than debug parameters. This patch fixes this oversight. --- src/core/MOM.F90 | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index 80cc36c577..a4e1336dc6 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -2019,7 +2019,8 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & ! Grid rotation test call get_param(param_file, "MOM", "ROTATE_INDEX", CS%rotate_index, & - "Enable rotation of the horizontal indices.", default=.false.) + "Enable rotation of the horizontal indices.", default=.false., & + debuggingParam=.true.) if (CS%rotate_index) then ! TODO: Index rotation currently only works when index rotation does not ! change the MPI rank of each domain. Resolving this will require a @@ -2030,7 +2031,8 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & call MOM_error(FATAL, "Index rotation is only supported on one PE.") call get_param(param_file, "MOM", "INDEX_TURNS", turns, & - "Number of counterclockwise quarter-turn index rotations.", default=1) + "Number of counterclockwise quarter-turn index rotations.", & + default=1, debuggingParam=.true.) endif ! Set up the model domain and grids. From 9cab5ef0d775811049706a7437c76bd48d6f4388 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Tue, 28 Apr 2020 21:47:44 -0400 Subject: [PATCH 237/316] Use deferred sums in MOM_sum_output Defer the global sums of fresh_water_in_EFP, etc., from accumulate_net_fluxes to the point where these accumulated fluxes are used in write_energy, and do the global sums for up to 5 variables simultaneously. The reduction in the number of (blocking) global sums should accelerate the code execution, and because these calculations use reproducing sums, answers are unchanged by altering the order of the sums. All answers are bitwise identical. --- src/diagnostics/MOM_sum_output.F90 | 140 +++++++++++++++-------------- 1 file changed, 73 insertions(+), 67 deletions(-) diff --git a/src/diagnostics/MOM_sum_output.F90 b/src/diagnostics/MOM_sum_output.F90 index de0f4eb8cd..c61ce6f935 100644 --- a/src/diagnostics/MOM_sum_output.F90 +++ b/src/diagnostics/MOM_sum_output.F90 @@ -5,8 +5,8 @@ module MOM_sum_output use iso_fortran_env, only : int64 use MOM_coms, only : sum_across_PEs, PE_here, root_PE, num_PEs, max_across_PEs -use MOM_coms, only : reproducing_sum, EFP_to_real, real_to_EFP -use MOM_coms, only : EFP_type, operator(+), operator(-), assignment(=) +use MOM_coms, only : reproducing_sum, reproducing_sum_EFP, EFP_to_real, real_to_EFP +use MOM_coms, only : EFP_type, operator(+), operator(-), assignment(=), EFP_sum_across_PEs 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 @@ -80,24 +80,18 @@ module MOM_sum_output !< Automatically update the Depth_list.nc file if the !! checksums are missing or do not match current values. logical :: use_temperature !< If true, temperature and salinity are state variables. - real :: fresh_water_input !< The total mass of fresh water added by surface fluxes - !! since the last time that write_energy was called [kg]. - real :: mass_prev !< The total ocean mass the last time that - !! write_energy was called [kg]. - real :: salt_prev !< The total amount of salt in the ocean the last - !! time that write_energy was called [ppt kg]. - real :: net_salt_input !< The total salt added by surface fluxes since the last - !! time that write_energy was called [ppt kg]. - real :: heat_prev !< The total amount of heat in the ocean the last - !! time that write_energy was called [J]. - real :: net_heat_input !< The total heat added by surface fluxes since the last - !! the last time that write_energy was called [J]. - type(EFP_type) :: fresh_water_in_EFP !< An extended fixed point version of fresh_water_input - type(EFP_type) :: net_salt_in_EFP !< An extended fixed point version of net_salt_input - type(EFP_type) :: net_heat_in_EFP !< An extended fixed point version of net_heat_input - type(EFP_type) :: heat_prev_EFP !< An extended fixed point version of heat_prev - type(EFP_type) :: salt_prev_EFP !< An extended fixed point version of salt_prev - type(EFP_type) :: mass_prev_EFP !< An extended fixed point version of mass_prev + type(EFP_type) :: fresh_water_in_EFP !< The total mass of fresh water added by surface fluxes on + !! this PE since the last time that write_energy was called [kg]. + type(EFP_type) :: net_salt_in_EFP !< The total salt added by surface fluxes on this PE since + !! the last time that write_energy was called [ppt kg]. + type(EFP_type) :: net_heat_in_EFP !< The total heat added by surface fluxes on this PE since + !! the last time that write_energy was called [J]. + type(EFP_type) :: heat_prev_EFP !< The total amount of heat in the ocean the last + !! time that write_energy was called [J]. + type(EFP_type) :: salt_prev_EFP !< The total amount of salt in the ocean the last + !! time that write_energy was called [ppt kg]. + type(EFP_type) :: mass_prev_EFP !< The total ocean mass the last time that + !! write_energy was called [kg]. real :: dt_in_T !< The baroclinic dynamics time step [T ~> s]. type(time_type) :: energysavedays !< The interval between writing the energies @@ -355,12 +349,9 @@ subroutine write_energy(u, v, h, tv, day, n, G, GV, US, CS, tracer_CSp, OBC, dt_ ! to this subroutine divided by total mass [ppt]. real :: salin_anom ! The change in total salt that cannot be accounted for by ! the surface fluxes divided by total mass [ppt]. - real :: salin_mass_in ! The mass of salt input since the last call [kg]. real :: Heat ! The total amount of Heat in the ocean [J]. - real :: Heat_chg ! The change in total ocean heat since the last call - ! to this subroutine [J]. - real :: Heat_anom ! The change in heat that cannot be accounted for by - ! the surface fluxes [J]. + real :: Heat_chg ! The change in total ocean heat since the last call to this subroutine [J]. + real :: Heat_anom ! The change in heat that cannot be accounted for by the surface fluxes [J]. real :: temp ! The mean potential temperature of the ocean [degC]. real :: temp_chg ! The change in total heat divided by total heat capacity ! of the ocean since the last call to this subroutine, degC. @@ -373,9 +364,19 @@ subroutine write_energy(u, v, h, tv, day, n, G, GV, US, CS, tracer_CSp, OBC, dt_ ! This makes PE only include real fluid. real :: hbelow ! The depth of fluid in all layers beneath an interface [Z ~> m]. type(EFP_type) :: & - mass_EFP, & ! Extended fixed point sums of total mass, etc. - salt_EFP, heat_EFP, salt_chg_EFP, heat_chg_EFP, mass_chg_EFP, & - mass_anom_EFP, salt_anom_EFP, heat_anom_EFP + mass_EFP, & ! The total mass of the ocean in extended fixed point form [kg]. + salt_EFP, & ! The total amount of salt in the ocean in extended fixed point form [ppt kg]. + heat_EFP, & ! The total amount of heat in the ocean in extended fixed point form [J]. + salt_chg_EFP, & ! The change in total ocean salt since the last call to this subroutine [ppt kg]. + heat_chg_EFP, & ! The change in total ocean heat since the last call to this subroutine [J]. + mass_chg_EFP, & ! The change in total ocean mass of fresh water since + ! the last call to this subroutine [kg]. + salt_anom_EFP, & ! The change in salt that cannot be accounted for by the surface + ! fluxes [ppt kg]. + heat_anom_EFP, & ! The change in heat that cannot be accounted for by the surface fluxes [J]. + mass_anom_EFP ! The change in fresh water that cannot be accounted for by the surface + ! fluxes [kg]. + type(EFP_type), dimension(5) :: EFP_list ! An array of EFP types for joint global sums. real :: CFL_Iarea ! Direction-based inverse area used in CFL test [L-2]. real :: CFL_trans ! A transport-based definition of the CFL number [nondim]. real :: CFL_lin ! A simpler definition of the CFL number [nondim]. @@ -568,10 +569,12 @@ subroutine write_energy(u, v, h, tv, day, n, G, GV, US, CS, tracer_CSp, OBC, dt_ endif if (CS%previous_calls == 0) then - CS%mass_prev = mass_tot ; CS%fresh_water_input = 0.0 CS%mass_prev_EFP = mass_EFP CS%fresh_water_in_EFP = real_to_EFP(0.0) + if (CS%use_temperature) then + CS%net_salt_in_EFP = real_to_EFP(0.0) ; CS%net_heat_in_EFP = real_to_EFP(0.0) + endif ! Reopen or create a text output file, with an explanatory header line. if (is_root_pe()) then @@ -713,8 +716,21 @@ subroutine write_energy(u, v, h, tv, day, n, G, GV, US, CS, tracer_CSp, OBC, dt_ Temp_int(i,j) = Temp_int(i,j) + (US%Q_to_J_kg*tv%C_p * tv%T(i,j,k)) * & (h(i,j,k)*(HL2_to_kg * areaTm(i,j))) enddo ; enddo ; enddo - Salt = reproducing_sum(Salt_int, EFP_sum=salt_EFP) - Heat = reproducing_sum(Temp_int, EFP_sum=heat_EFP) + salt_EFP = reproducing_sum_EFP(Salt_int, only_on_PE=.true.) + heat_EFP = reproducing_sum_EFP(Temp_int, only_on_PE=.true.) + + ! Combining the sums avoids multiple blocking all-PE updates. + EFP_list(1) = salt_EFP ; EFP_list(2) = heat_EFP ; EFP_list(3) = CS%fresh_water_in_EFP + EFP_list(4) = CS%net_salt_in_EFP ; EFP_list(5) = CS%net_heat_in_EFP + call EFP_sum_across_PEs(EFP_list, 5) + ! Return the globally summed values to the original variables. + salt_EFP = EFP_list(1) ; heat_EFP = EFP_list(2) ; CS%fresh_water_in_EFP = EFP_list(3) + CS%net_salt_in_EFP = EFP_list(4) ; CS%net_heat_in_EFP = EFP_list(5) + + Salt = EFP_to_real(salt_EFP) + Heat = EFP_to_real(heat_EFP) + else + call EFP_sum_across_PEs(CS%fresh_water_in_EFP) endif ! Calculate the maximum CFL numbers. @@ -746,38 +762,31 @@ subroutine write_energy(u, v, h, tv, day, n, G, GV, US, CS, tracer_CSp, OBC, dt_ ! The sum of Tr_stocks should be reimplemented using the reproducing sums. if (nTr_stocks > 0) call sum_across_PEs(Tr_stocks,nTr_stocks) - call max_across_PEs(max_CFL(1)) - call max_across_PEs(max_CFL(2)) - if (CS%use_temperature .and. CS%previous_calls == 0) then - CS%salt_prev = Salt ; CS%net_salt_input = 0.0 - CS%heat_prev = Heat ; CS%net_heat_input = 0.0 - - CS%salt_prev_EFP = salt_EFP ; CS%net_salt_in_EFP = real_to_EFP(0.0) - CS%heat_prev_EFP = heat_EFP ; CS%net_heat_in_EFP = real_to_EFP(0.0) - endif + call max_across_PEs(max_CFL, 2) Irho0 = 1.0 / (US%R_to_kg_m3*GV%Rho0) if (CS%use_temperature) then + if (CS%previous_calls == 0) then + CS%salt_prev_EFP = salt_EFP ; CS%heat_prev_EFP = heat_EFP + endif Salt_chg_EFP = Salt_EFP - CS%salt_prev_EFP + Salt_chg = EFP_to_real(Salt_chg_EFP) Salt_anom_EFP = Salt_chg_EFP - CS%net_salt_in_EFP - Salt_chg = EFP_to_real(Salt_chg_EFP) ; Salt_anom = EFP_to_real(Salt_anom_EFP) + Salt_anom = EFP_to_real(Salt_anom_EFP) Heat_chg_EFP = Heat_EFP - CS%heat_prev_EFP + Heat_chg = EFP_to_real(Heat_chg_EFP) Heat_anom_EFP = Heat_chg_EFP - CS%net_heat_in_EFP - Heat_chg = EFP_to_real(Heat_chg_EFP) ; Heat_anom = EFP_to_real(Heat_anom_EFP) + Heat_anom = EFP_to_real(Heat_anom_EFP) endif mass_chg_EFP = mass_EFP - CS%mass_prev_EFP - salin_mass_in = 0.0 - if (GV%Boussinesq) then - mass_anom_EFP = mass_chg_EFP - CS%fresh_water_in_EFP - else + mass_anom_EFP = mass_chg_EFP - CS%fresh_water_in_EFP + mass_anom = EFP_to_real(mass_anom_EFP) + if (CS%use_temperature .and. .not.GV%Boussinesq) then ! net_salt_input needs to be converted from ppt m s-1 to kg m-2 s-1. - mass_anom_EFP = mass_chg_EFP - CS%fresh_water_in_EFP - if (CS%use_temperature) & - salin_mass_in = 0.001*EFP_to_real(CS%net_salt_in_EFP) + mass_anom = mass_anom - 0.001*EFP_to_real(CS%net_salt_in_EFP) endif mass_chg = EFP_to_real(mass_chg_EFP) - mass_anom = EFP_to_real(mass_anom_EFP) - salin_mass_in if (CS%use_temperature) then salin = Salt / mass_tot ; salin_anom = Salt_anom / mass_tot @@ -894,7 +903,7 @@ subroutine write_energy(u, v, h, tv, day, n, G, GV, US, CS, tracer_CSp, OBC, dt_ call write_field(CS%fileenergy_nc, CS%fields(8), mass_chg, reday) call write_field(CS%fileenergy_nc, CS%fields(9), mass_anom, reday) call write_field(CS%fileenergy_nc, CS%fields(10), max_CFL(1), reday) - call write_field(CS%fileenergy_nc, CS%fields(11), max_CFL(1), reday) + call write_field(CS%fileenergy_nc, CS%fields(11), max_CFL(2), reday) if (CS%use_temperature) then call write_field(CS%fileenergy_nc, CS%fields(12), 0.001*Salt, reday) call write_field(CS%fileenergy_nc, CS%fields(13), 0.001*salt_chg, reday) @@ -926,17 +935,13 @@ subroutine write_energy(u, v, h, tv, day, n, G, GV, US, CS, tracer_CSp, OBC, dt_ endif CS%ntrunc = 0 CS%previous_calls = CS%previous_calls + 1 - CS%mass_prev = mass_tot ; CS%fresh_water_input = 0.0 - if (CS%use_temperature) then - CS%salt_prev = Salt ; CS%net_salt_input = 0.0 - CS%heat_prev = Heat ; CS%net_heat_input = 0.0 - endif CS%mass_prev_EFP = mass_EFP ; CS%fresh_water_in_EFP = real_to_EFP(0.0) if (CS%use_temperature) then CS%salt_prev_EFP = Salt_EFP ; CS%net_salt_in_EFP = real_to_EFP(0.0) CS%heat_prev_EFP = Heat_EFP ; CS%net_heat_in_EFP = real_to_EFP(0.0) endif + end subroutine write_energy !> This subroutine accumates the net input of volume, salt and heat, through @@ -970,9 +975,12 @@ subroutine accumulate_net_input(fluxes, sfc_state, tv, dt, G, US, CS) real :: QRZL2_to_J ! A combination of scaling factors for heat [J Q-1 R-1 Z-1 L-2 ~> 1] type(EFP_type) :: & - FW_in_EFP, & ! Extended fixed point version of FW_input [kg] - salt_in_EFP, & ! Extended fixed point version of salt_input [ppt kg] - heat_in_EFP ! Extended fixed point version of heat_input [J] + FW_in_EFP, & ! The net fresh water input, integrated over a timestep + ! and summed over space [kg]. + salt_in_EFP, & ! The total salt added by surface fluxes, integrated + ! over a time step and summed over space [ppt kg]. + heat_in_EFP ! The total heat added by boundary fluxes, integrated + ! over a time step and summed over space [J]. real :: inputs(3) ! A mixed array for combining the sums integer :: i, j, is, ie, js, je @@ -982,7 +990,7 @@ subroutine accumulate_net_input(fluxes, sfc_state, tv, dt, G, US, CS) RZL2_to_kg = US%L_to_m**2*US%RZ_to_kg_m2 QRZL2_to_J = RZL2_to_kg*US%Q_to_J_kg - FW_in(:,:) = 0.0 ; FW_input = 0.0 + FW_in(:,:) = 0.0 if (associated(fluxes%evap)) then if (associated(fluxes%lprec) .and. associated(fluxes%fprec)) then do j=js,je ; do i=is,ie @@ -1060,13 +1068,11 @@ subroutine accumulate_net_input(fluxes, sfc_state, tv, dt, G, US, CS) 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) - - CS%fresh_water_input = CS%fresh_water_input + FW_input - CS%net_salt_input = CS%net_salt_input + salt_input - CS%net_heat_input = CS%net_heat_input + heat_input + !### The on-PE sums should be stored here, but the sum across PEs should be deferred to + ! the next call to write_energy to avoid extra barriers. + FW_in_EFP = reproducing_sum_EFP(FW_in, only_on_PE=.true.) + heat_in_EFP = reproducing_sum_EFP(heat_in, only_on_PE=.true.) + salt_in_EFP = reproducing_sum_EFP(salt_in, only_on_PE=.true.) CS%fresh_water_in_EFP = CS%fresh_water_in_EFP + FW_in_EFP CS%net_salt_in_EFP = CS%net_salt_in_EFP + salt_in_EFP From 130970e730b5882f33265a36a2a0d0418482352f Mon Sep 17 00:00:00 2001 From: Angus Gibson Date: Wed, 29 Apr 2020 14:16:10 +1000 Subject: [PATCH 238/316] Fix remapped diagnostic documentation --- src/framework/_Diagnostics.dox | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/framework/_Diagnostics.dox b/src/framework/_Diagnostics.dox index 51a1cd35c7..44b3a6afe7 100644 --- a/src/framework/_Diagnostics.dox +++ b/src/framework/_Diagnostics.dox @@ -180,8 +180,8 @@ To obtain a diagnostic of monthly-averaged potential temperature in both these c ``` "ocean_month_z", 1, "months", 1, "days", "time" "ocean_month_abc", 1, "months", 1, "days", "time" -"ocean_model", "temp", "temp", "ocean_month_z", "all", "mean", "none",2 -"ocean_model", "temp", "temp", "ocean_month_abc", "all", "mean", "none",2 +"ocean_model_z", "temp", "temp", "ocean_month_z", "all", "mean", "none",2 +"ocean_model_abc", "temp", "temp", "ocean_month_abc", "all", "mean", "none",2 ``` From 64931829dd0a384202813ee87b08d6c5f576691c Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 29 Apr 2020 09:50:00 -0400 Subject: [PATCH 239/316] +Added EFP_lay_sums argument to reproducing_sum_3d Added the new optional EFP_lay_sums argument to reproducing_sum_3d, to return extended fixed point versions of the sums by layer. All answers are bitwise identical. --- src/framework/MOM_coms.F90 | 24 +++++++++++++++++------- 1 file changed, 17 insertions(+), 7 deletions(-) diff --git a/src/framework/MOM_coms.F90 b/src/framework/MOM_coms.F90 index dd367b3c4b..0c6b948980 100644 --- a/src/framework/MOM_coms.F90 +++ b/src/framework/MOM_coms.F90 @@ -320,7 +320,7 @@ end function reproducing_sum_2d !! 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, only_on_PE) & +function reproducing_sum_3d(array, isr, ier, jsr, jer, sums, EFP_sum, EFP_lay_sums, err, only_on_PE) & result(sum) real, dimension(:,:,:), intent(in) :: array !< The array to be summed integer, optional, intent(in) :: isr !< The starting i-index of the sum, noting @@ -333,6 +333,8 @@ function reproducing_sum_3d(array, isr, ier, jsr, jer, sums, EFP_sum, err, only_ !! 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 + type(EFP_type), dimension(:), & + optional, intent(out) :: EFP_lay_sums !< The sums by vertical layer in EFP format integer, optional, intent(out) :: err !< If present, return an error code instead of !! triggering any fatal errors directly from !! this routine. @@ -344,7 +346,7 @@ function reproducing_sum_3d(array, isr, ier, jsr, jer, sums, EFP_sum, err, only_ ! of real numbers to give order-invariant sums that will reproduce ! across PE count. This idea comes from R. Hallberg and A. Adcroft. - real :: max_mag_term + real :: val, max_mag_term integer(kind=8), dimension(ni) :: ints_sum integer(kind=8), dimension(ni,size(array,3)) :: ints_sums integer(kind=8) :: prec_error @@ -380,9 +382,13 @@ function reproducing_sum_3d(array, isr, ier, jsr, jer, sums, EFP_sum, err, only_ do_sum_across_PEs = .true. ; if (present(only_on_PE)) do_sum_across_PEs = .not.only_on_PE - if (present(sums)) then - if (size(sums) > ke) call MOM_error(FATAL, "Sums is smaller than "//& - "the vertical extent of array in reproducing_sum(_3d).") + if (present(sums) .or. present(EFP_lay_sums)) then + if (present(sums)) then ; if (size(sums) < ke) then + call MOM_error(FATAL, "Sums is smaller than the vertical extent of array in reproducing_sum(_3d).") + endif ; endif + if (present(EFP_lay_sums)) then ; if (size(EFP_lay_sums) < ke) then + call MOM_error(FATAL, "Sums is smaller than the vertical extent of array in reproducing_sum(_3d).") + endif ; endif ints_sums(:,:) = 0 overflow_error = .false. ; NaN_error = .false. ; max_mag_term = 0.0 if (jsz*isz < max_count_prec) then @@ -425,9 +431,13 @@ function reproducing_sum_3d(array, isr, ier, jsr, jer, sums, EFP_sum, err, only_ sum = 0.0 do k=1,ke call regularize_ints(ints_sums(:,k)) - sums(k) = ints_to_real(ints_sums(:,k)) - sum = sum + sums(k) + val = ints_to_real(ints_sums(:,k)) + if (present(sums)) sums(k) = val + sum = sum + val enddo + if (present(EFP_lay_sums)) then ; do k=1,ke + EFP_lay_sums(k)%v(:) = ints_sums(:,k) + enddo ; endif if (present(EFP_sum)) then EFP_sum%v(:) = 0 From 18d8f90cd00aa037eb4935eba4d096fbbf5be9f9 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 29 Apr 2020 09:51:09 -0400 Subject: [PATCH 240/316] Do sums for write_energy on computational domain Limit sums to computational domain in calls to reproducing_sum from MOM_sum_output. The solutions do not change because the halos in the arrays in question all had zero values, but working only over the proper array extent will be more efficient. All answers are bitwise identical. --- src/diagnostics/MOM_sum_output.F90 | 31 ++++++++++++++++-------------- 1 file changed, 17 insertions(+), 14 deletions(-) diff --git a/src/diagnostics/MOM_sum_output.F90 b/src/diagnostics/MOM_sum_output.F90 index c61ce6f935..2d4fb7e06f 100644 --- a/src/diagnostics/MOM_sum_output.F90 +++ b/src/diagnostics/MOM_sum_output.F90 @@ -395,7 +395,7 @@ subroutine write_energy(u, v, h, tv, day, n, G, GV, US, CS, tracer_CSp, OBC, dt_ ! calculation [kg T2 R-1 Z-1 L-2 s-2 ~> nondim] integer :: num_nc_fields ! The number of fields that will actually go into ! the NetCDF file. - integer :: i, j, k, is, ie, js, je, ns, nz, m, Isq, Ieq, Jsq, Jeq + integer :: i, j, k, is, ie, js, je, ns, nz, m, Isq, Ieq, Jsq, Jeq, isr, ier, jsr, jer integer :: l, lbelow, labove ! indices of deep_area_vol, used to find Z_0APE. ! lbelow & labove are lower & upper limits for l ! in the search for the entry in lH to use. @@ -483,6 +483,8 @@ subroutine write_energy(u, v, h, tv, day, n, G, GV, US, CS, tracer_CSp, OBC, 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 + isr = is - (G%isd-1) ; ier = ie - (G%isd-1) ; jsr = js - (G%jsd-1) ; jer = je - (G%jsd-1) + HL2_to_kg = GV%H_to_kg_m2*US%L_to_m**2 @@ -527,7 +529,7 @@ subroutine write_energy(u, v, h, tv, day, n, G, GV, US, CS, tracer_CSp, OBC, dt_ enddo endif - mass_tot = reproducing_sum(tmp1, sums=mass_lay, EFP_sum=mass_EFP) + mass_tot = reproducing_sum(tmp1, isr, ier, jsr, jer, sums=mass_lay, EFP_sum=mass_EFP) do k=1,nz ; vol_lay(k) = (US%m_to_L**2*GV%H_to_Z/GV%H_to_kg_m2)*mass_lay(k) ; enddo else tmp1(:,:,:) = 0.0 @@ -535,19 +537,19 @@ subroutine write_energy(u, v, h, tv, day, n, G, GV, US, CS, tracer_CSp, OBC, dt_ do k=1,nz ; do j=js,je ; do i=is,ie tmp1(i,j,k) = HL2_to_kg * h(i,j,k) * areaTm(i,j) enddo ; enddo ; enddo - mass_tot = reproducing_sum(tmp1, sums=mass_lay, EFP_sum=mass_EFP) + mass_tot = reproducing_sum(tmp1, isr, ier, jsr, jer, sums=mass_lay, EFP_sum=mass_EFP) call find_eta(h, tv, G, GV, US, eta) do k=1,nz ; do j=js,je ; do i=is,ie tmp1(i,j,k) = US%Z_to_m*US%L_to_m**2*(eta(i,j,K)-eta(i,j,K+1)) * areaTm(i,j) enddo ; enddo ; enddo - vol_tot = reproducing_sum(tmp1, sums=vol_lay) + vol_tot = reproducing_sum(tmp1, isr, ier, jsr, jer, sums=vol_lay) do k=1,nz ; vol_lay(k) = US%m_to_Z*US%m_to_L**2 * vol_lay(k) ; enddo else do k=1,nz ; do j=js,je ; do i=is,ie tmp1(i,j,k) = HL2_to_kg * h(i,j,k) * areaTm(i,j) enddo ; enddo ; enddo - mass_tot = reproducing_sum(tmp1, sums=mass_lay, EFP_sum=mass_EFP) + mass_tot = reproducing_sum(tmp1, isr, ier, jsr, jer, sums=mass_lay, EFP_sum=mass_EFP) do k=1,nz ; vol_lay(k) = US%m_to_Z*US%m_to_L**2*US%kg_m3_to_R * (mass_lay(k) / GV%Rho0) ; enddo endif endif ! Boussinesq @@ -689,7 +691,7 @@ subroutine write_energy(u, v, h, tv, day, n, G, GV, US, CS, tracer_CSp, OBC, dt_ enddo ; enddo endif - PE_tot = reproducing_sum(PE_pt, sums=PE) + PE_tot = reproducing_sum(PE_pt, isr, ier, jsr, jer, sums=PE) do k=1,nz+1 ; H_0APE(K) = US%Z_to_m*Z_0APE(K) ; enddo else PE_tot = 0.0 @@ -703,7 +705,7 @@ subroutine write_energy(u, v, h, tv, day, n, G, GV, US, CS, tracer_CSp, OBC, dt_ tmp1(i,j,k) = (0.25 * KE_scale_factor * (areaTm(i,j) * h(i,j,k))) * & (u(I-1,j,k)**2 + u(I,j,k)**2 + v(i,J-1,k)**2 + v(i,J,k)**2) enddo ; enddo ; enddo - KE_tot = reproducing_sum(tmp1, sums=KE) + KE_tot = reproducing_sum(tmp1, isr, ier, jsr, jer, sums=KE) toten = KE_tot + PE_tot @@ -716,8 +718,8 @@ subroutine write_energy(u, v, h, tv, day, n, G, GV, US, CS, tracer_CSp, OBC, dt_ Temp_int(i,j) = Temp_int(i,j) + (US%Q_to_J_kg*tv%C_p * tv%T(i,j,k)) * & (h(i,j,k)*(HL2_to_kg * areaTm(i,j))) enddo ; enddo ; enddo - salt_EFP = reproducing_sum_EFP(Salt_int, only_on_PE=.true.) - heat_EFP = reproducing_sum_EFP(Temp_int, only_on_PE=.true.) + salt_EFP = reproducing_sum_EFP(Salt_int, isr, ier, jsr, jer, only_on_PE=.true.) + heat_EFP = reproducing_sum_EFP(Temp_int, isr, ier, jsr, jer, only_on_PE=.true.) ! Combining the sums avoids multiple blocking all-PE updates. EFP_list(1) = salt_EFP ; EFP_list(2) = heat_EFP ; EFP_list(3) = CS%fresh_water_in_EFP @@ -983,7 +985,7 @@ subroutine accumulate_net_input(fluxes, sfc_state, tv, dt, G, US, CS) ! over a time step and summed over space [J]. real :: inputs(3) ! A mixed array for combining the sums - integer :: i, j, is, ie, js, je + integer :: i, j, is, ie, js, je, isr, ier, jsr, jer is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec @@ -1068,11 +1070,12 @@ subroutine accumulate_net_input(fluxes, sfc_state, tv, dt, G, US, CS) if ((CS%use_temperature) .or. associated(fluxes%lprec) .or. & associated(fluxes%evap)) then - !### The on-PE sums should be stored here, but the sum across PEs should be deferred to + ! The on-PE sums are stored here, but the sums across PEs are deferred to ! the next call to write_energy to avoid extra barriers. - FW_in_EFP = reproducing_sum_EFP(FW_in, only_on_PE=.true.) - heat_in_EFP = reproducing_sum_EFP(heat_in, only_on_PE=.true.) - salt_in_EFP = reproducing_sum_EFP(salt_in, only_on_PE=.true.) + isr = is - (G%isd-1) ; ier = ie - (G%isd-1) ; jsr = js - (G%jsd-1) ; jer = je - (G%jsd-1) + FW_in_EFP = reproducing_sum_EFP(FW_in, isr, ier, jsr, jer, only_on_PE=.true.) + heat_in_EFP = reproducing_sum_EFP(heat_in, isr, ier, jsr, jer, only_on_PE=.true.) + salt_in_EFP = reproducing_sum_EFP(salt_in, isr, ier, jsr, jer, only_on_PE=.true.) CS%fresh_water_in_EFP = CS%fresh_water_in_EFP + FW_in_EFP CS%net_salt_in_EFP = CS%net_salt_in_EFP + salt_in_EFP From 9cb4b3940ddcf1d753620a2bccf59e690411d105 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 29 Apr 2020 09:52:36 -0400 Subject: [PATCH 241/316] Use reproducing_sums in 3 diagnostic subroutines Replaced sum_across_PEs with reproducing_sums in MOM_state_stats, totalStuff and totalTandS. All solutions are bitwise identical, and diagnostic messages will now be invariant to domain decomposition. --- src/core/MOM_checksum_packages.F90 | 33 ++++++++++++++++++++---------- src/diagnostics/MOM_debugging.F90 | 20 ++++++++++-------- 2 files changed, 33 insertions(+), 20 deletions(-) diff --git a/src/core/MOM_checksum_packages.F90 b/src/core/MOM_checksum_packages.F90 index bc586e1a2f..5fb96c1c73 100644 --- a/src/core/MOM_checksum_packages.F90 +++ b/src/core/MOM_checksum_packages.F90 @@ -6,8 +6,8 @@ module MOM_checksum_packages ! This module provides several routines that do check-sums of groups ! of variables in the various dynamic solver routines. +use MOM_coms, only : min_across_PEs, max_across_PEs, reproducing_sum use MOM_debugging, only : hchksum, uvchksum -use MOM_domains, only : sum_across_PEs, min_across_PEs, max_across_PEs use MOM_error_handler, only : MOM_mesg, is_root_pe use MOM_grid, only : ocean_grid_type use MOM_unit_scaling, only : unit_scale_type @@ -251,6 +251,11 @@ subroutine MOM_state_stats(mesg, u, v, h, Temp, Salt, G, GV, US, allowChange, pe !! extrema are diminishing. ! Local variables + real, dimension(G%isc:G%iec, G%jsc:G%jec) :: & + tmp_A, & ! The area per cell [m2] (unscaled to permit reproducing sum). + tmp_V, & ! The column-integrated volume [m3] (unscaled to permit reproducing sum) + tmp_T, & ! The column-integrated temperature [degC m3] + tmp_S ! The column-integrated salinity [ppt m3] real :: Vol, dV ! The total ocean volume and its change [m3] (unscaled to permit reproducing sum). real :: Area ! The total ocean surface area [m2] (unscaled to permit reproducing sum). real :: h_minimum ! The minimum layer thicknesses [H ~> m or kg m-2] @@ -269,17 +274,22 @@ subroutine MOM_state_stats(mesg, u, v, h, Temp, Salt, G, GV, US, allowChange, pe is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke do_TS = associated(Temp) .and. associated(Salt) + tmp_A(:,:) = 0.0 + tmp_V(:,:) = 0.0 + tmp_T(:,:) = 0.0 + tmp_S(:,:) = 0.0 + ! First collect local stats - Area = 0. ; Vol = 0. - do j = js, je ; do i = is, ie - Area = Area + US%L_to_m**2*G%areaT(i,j) + do j=js,je ; do i=is,ie + tmp_A(i,j) = tmp_A(i,j) + US%L_to_m**2*G%areaT(i,j) enddo ; enddo T%minimum = 1.E34 ; T%maximum = -1.E34 ; T%average = 0. S%minimum = 1.E34 ; S%maximum = -1.E34 ; S%average = 0. h_minimum = 1.E34*GV%m_to_H - do k = 1, nz ; do j = js, je ; do i = is, ie + do k=1,nz ; do j=js,je ; do i=is,ie if (G%mask2dT(i,j)>0.) then - dV = US%L_to_m**2*G%areaT(i,j)*GV%H_to_m*h(i,j,k) ; Vol = Vol + dV + dV = US%L_to_m**2*G%areaT(i,j)*GV%H_to_m*h(i,j,k) + tmp_V(i,j) = tmp_V(i,j) + dV if (do_TS .and. h(i,j,k)>0.) then T%minimum = min( T%minimum, Temp(i,j,k) ) ; T%maximum = max( T%maximum, Temp(i,j,k) ) T%average = T%average + dV*Temp(i,j,k) @@ -289,10 +299,11 @@ subroutine MOM_state_stats(mesg, u, v, h, Temp, Salt, G, GV, US, allowChange, pe if (h_minimum > h(i,j,k)) h_minimum = h(i,j,k) endif enddo ; enddo ; enddo - call sum_across_PEs( Area ) ; call sum_across_PEs( Vol ) + Area = reproducing_sum( tmp_A ) ; Vol = reproducing_sum( tmp_V ) if (do_TS) then - call min_across_PEs( T%minimum ) ; call max_across_PEs( T%maximum ) ; call sum_across_PEs( T%average ) - call min_across_PEs( S%minimum ) ; call max_across_PEs( S%maximum ) ; call sum_across_PEs( S%average ) + call min_across_PEs( T%minimum ) ; call max_across_PEs( T%maximum ) + call min_across_PEs( S%minimum ) ; call max_across_PEs( S%maximum ) + T%average = reproducing_sum( tmp_T ) ; S%average = reproducing_sum( tmp_S ) T%average = T%average / Vol ; S%average = S%average / Vol endif if (is_root_pe()) then @@ -330,7 +341,7 @@ subroutine MOM_state_stats(mesg, u, v, h, Temp, Salt, G, GV, US, allowChange, pe oldS%minimum = S%minimum ; oldS%maximum = S%maximum ; oldS%average = S%average if (do_TS .and. T%minimum<-5.0) then - do j = js, je ; do i = is, ie + do j=js,je ; do i=is,ie if (minval(Temp(i,j,:)) == T%minimum) then write(0,'(a,2f12.5)') 'x,y=', G%geoLonT(i,j), G%geoLatT(i,j) write(0,'(a3,3a12)') 'k','h','Temp','Salt' @@ -343,7 +354,7 @@ subroutine MOM_state_stats(mesg, u, v, h, Temp, Salt, G, GV, US, allowChange, pe endif if (h_minimum<0.0) then - do j = js, je ; do i = is, ie + do j=js,je ; do i=is,ie if (minval(h(i,j,:)) == h_minimum) then write(0,'(a,2f12.5)') 'x,y=',G%geoLonT(i,j),G%geoLatT(i,j) write(0,'(a3,3a12)') 'k','h','Temp','Salt' diff --git a/src/diagnostics/MOM_debugging.F90 b/src/diagnostics/MOM_debugging.F90 index 611e6da2fc..29f7f0f123 100644 --- a/src/diagnostics/MOM_debugging.F90 +++ b/src/diagnostics/MOM_debugging.F90 @@ -10,7 +10,7 @@ module MOM_debugging use MOM_checksums, only : hchksum, Bchksum, qchksum, uvchksum, hchksum_pair use MOM_checksums, only : is_NaN, chksum, MOM_checksums_init -use MOM_coms, only : PE_here, root_PE, num_PEs, sum_across_PEs +use MOM_coms, only : PE_here, root_PE, num_PEs use MOM_coms, only : min_across_PEs, max_across_PEs, reproducing_sum use MOM_domains, only : pass_vector, pass_var, pe_here use MOM_domains, only : BGRID_NE, AGRID, To_All, Scalar_Pair @@ -730,14 +730,15 @@ function totalStuff(HI, hThick, areaT, stuff) real, dimension(HI%isd:,HI%jsd:,:), intent(in) :: stuff !< The array of stuff to be summed real :: totalStuff !< the globally integrated amoutn of stuff ! Local variables + real, dimension(HI%isc:HI%iec, HI%jsc:HI%jec) :: tmp_for_sum integer :: i, j, k, nz nz = size(hThick,3) - totalStuff = 0. - do k = 1, nz ; do j = HI%jsc, HI%jec ; do i = HI%isc, HI%iec - totalStuff = totalStuff + hThick(i,j,k) * stuff(i,j,k) * areaT(i,j) + tmp_for_sum(:,:) = 0.0 + do k=1,nz ; do j=HI%jsc,HI%jec ; do i=HI%isc,HI%iec + tmp_for_sum(i,j) = tmp_for_sum(i,j) + hThick(i,j,k) * stuff(i,j,k) * areaT(i,j) enddo ; enddo ; enddo - call sum_across_PEs(totalStuff) + totalStuff = reproducing_sum(tmp_for_sum) end function totalStuff @@ -755,15 +756,16 @@ subroutine totalTandS(HI, hThick, areaT, temperature, salinity, mesg) real, save :: totalH = 0., totalT = 0., totalS = 0. ! Local variables logical, save :: firstCall = .true. + real, dimension(HI%isc:HI%iec, HI%jsc:HI%jec) :: tmp_for_sum real :: thisH, thisT, thisS, delH, delT, delS integer :: i, j, k, nz nz = size(hThick,3) - thisH = 0. - do k = 1, nz ; do j = HI%jsc, HI%jec ; do i = HI%isc, HI%iec - thisH = thisH + hThick(i,j,k) * areaT(i,j) + tmp_for_sum(:,:) = 0.0 + do k=1,nz ; do j=HI%jsc,HI%jec ; do i=HI%isc,HI%iec + tmp_for_sum(i,j) = tmp_for_sum(i,j) + hThick(i,j,k) * areaT(i,j) enddo ; enddo ; enddo - call sum_across_PEs(thisH) + thisH = reproducing_sum(tmp_for_sum) thisT = totalStuff(HI, hThick, areaT, temperature) thisS = totalStuff(HI, hThick, areaT, salinity) From 7936f8ead4d823a66f2fdb383b94e4846f6f29a8 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 29 Apr 2020 09:53:09 -0400 Subject: [PATCH 242/316] Merge global sums for diagnostics Combined global sum calls for diagnostics and spatial averages, for reduced blocking communication. All answers are bitwise identical. --- src/framework/MOM_diag_remap.F90 | 17 +++++++++--- src/framework/MOM_spatial_means.F90 | 42 ++++++++++++++++------------- 2 files changed, 37 insertions(+), 22 deletions(-) diff --git a/src/framework/MOM_diag_remap.F90 b/src/framework/MOM_diag_remap.F90 index a6c4602d9e..0fe937a173 100644 --- a/src/framework/MOM_diag_remap.F90 +++ b/src/framework/MOM_diag_remap.F90 @@ -57,7 +57,8 @@ module MOM_diag_remap ! This file is part of MOM6. See LICENSE.md for the license. -use MOM_coms, only : reproducing_sum +use MOM_coms, only : reproducing_sum_EFP, EFP_to_real +use MOM_coms, only : EFP_type, assignment(=), EFP_sum_across_PEs use MOM_error_handler, only : MOM_error, FATAL, assert, WARNING use MOM_diag_vkernels, only : interpolate_column, reintegrate_column use MOM_file_parser, only : get_param, log_param, param_file_type @@ -667,6 +668,7 @@ subroutine horizontally_average_diag_field(G, GV, h, staggered_in_x, staggered_i ! Local variables real, dimension(G%isc:G%iec, G%jsc:G%jec, size(field,3)) :: volume, stuff real, dimension(size(field, 3)) :: vol_sum, stuff_sum ! nz+1 is needed for interface averages + type(EFP_type), dimension(2*size(field,3)) :: sums_EFP ! Sums of volume or stuff by layer real :: height integer :: i, j, k, nz integer :: i1, j1 !< 1-based index @@ -771,9 +773,16 @@ subroutine horizontally_average_diag_field(G, GV, h, staggered_in_x, staggered_i call assert(.false., 'horizontally_average_diag_field: Q point averaging is not coded yet.') endif - do k = 1,nz - vol_sum(k) = reproducing_sum(volume(:,:,k)) - stuff_sum(k) = reproducing_sum(stuff(:,:,k)) + ! Packing the sums into a single array with a single call to sum across PEs saves reduces + ! the costs of communication. + do k=1,nz + sums_EFP(2*k-1) = reproducing_sum_EFP(volume(:,:,k), only_on_PE=.true.) + sums_EFP(2*k) = reproducing_sum_EFP(stuff(:,:,k), only_on_PE=.true.) + enddo + call EFP_sum_across_PEs(sums_EFP, 2*nz) + do k=1,nz + vol_sum(k) = EFP_to_real(sums_EFP(2*k-1)) + stuff_sum(k) = EFP_to_real(sums_EFP(2*k)) enddo averaged_mask(:) = .true. diff --git a/src/framework/MOM_spatial_means.F90 b/src/framework/MOM_spatial_means.F90 index 2423a19433..ffbdc5f810 100644 --- a/src/framework/MOM_spatial_means.F90 +++ b/src/framework/MOM_spatial_means.F90 @@ -4,8 +4,8 @@ module MOM_spatial_means ! This file is part of MOM6. See LICENSE.md for the license. use MOM_coms, only : EFP_type, operator(+), operator(-), assignment(=) -use MOM_coms, only : EFP_to_real, real_to_EFP, EFP_list_sum_across_PEs -use MOM_coms, only : reproducing_sum +use MOM_coms, only : EFP_to_real, real_to_EFP, EFP_sum_across_PEs +use MOM_coms, only : reproducing_sum, reproducing_sum_EFP, EFP_to_real use MOM_coms, only : query_EFP_overflow_error, reset_EFP_overflow_error use MOM_error_handler, only : MOM_error, NOTE, WARNING, FATAL, is_root_pe use MOM_file_parser, only : get_param, log_version, param_file_type @@ -88,8 +88,8 @@ function global_layer_mean(var, h, G, GV, scale) real, optional, intent(in) :: scale !< A rescaling factor for the variable real, dimension(SZK_(GV)) :: global_layer_mean - real, dimension(SZI_(G), SZJ_(G), SZK_(GV)) :: tmpForSumming, weight - real, dimension(SZK_(GV)) :: scalarij, weightij + real, dimension(G%isc:G%iec, G%jsc:G%jec, SZK_(GV)) :: tmpForSumming, weight + type(EFP_type), dimension(2*SZK_(GV)) :: laysums real, dimension(SZK_(GV)) :: global_temp_scalar, global_weight_scalar real :: scalefac ! A scaling factor for the variable. integer :: i, j, k, is, ie, js, je, nz @@ -103,11 +103,12 @@ function global_layer_mean(var, h, G, GV, scale) tmpForSumming(i,j,k) = scalefac * var(i,j,k) * weight(i,j,k) enddo ; enddo ; enddo - global_temp_scalar = reproducing_sum(tmpForSumming,sums=scalarij) - global_weight_scalar = reproducing_sum(weight,sums=weightij) + global_temp_scalar = reproducing_sum(tmpForSumming, EFP_lay_sums=laysums(1:nz), only_on_PE=.true.) + global_weight_scalar = reproducing_sum(weight, EFP_lay_sums=laysums(nz+1:2*nz), only_on_PE=.true.) + call EFP_sum_across_PEs(laysums, 2*nz) do k=1,nz - global_layer_mean(k) = scalarij(k) / weightij(k) + global_layer_mean(k) = EFP_to_real(laysums(k)) / EFP_to_real(laysums(nz+k)) enddo end function global_layer_mean @@ -236,8 +237,8 @@ subroutine global_i_mean(array, i_mean, G, mask, scale, tmp_scale) if (query_EFP_overflow_error()) call MOM_error(FATAL, & "global_i_mean overflow error occurred before sums across PEs.") - call EFP_list_sum_across_PEs(asum(G%jsg:G%jeg), G%jeg-G%jsg+1) - call EFP_list_sum_across_PEs(mask_sum(G%jsg:G%jeg), G%jeg-G%jsg+1) + call EFP_sum_across_PEs(asum(G%jsg:G%jeg), G%jeg-G%jsg+1) + call EFP_sum_across_PEs(mask_sum(G%jsg:G%jeg), G%jeg-G%jsg+1) if (query_EFP_overflow_error()) call MOM_error(FATAL, & "global_i_mean overflow error occurred during sums across PEs.") @@ -260,7 +261,7 @@ subroutine global_i_mean(array, i_mean, G, mask, scale, tmp_scale) if (query_EFP_overflow_error()) call MOM_error(FATAL, & "global_i_mean overflow error occurred before sum across PEs.") - call EFP_list_sum_across_PEs(asum(G%jsg:G%jeg), G%jeg-G%jsg+1) + call EFP_sum_across_PEs(asum(G%jsg:G%jeg), G%jeg-G%jsg+1) if (query_EFP_overflow_error()) call MOM_error(FATAL, & "global_i_mean overflow error occurred during sum across PEs.") @@ -322,8 +323,8 @@ subroutine global_j_mean(array, j_mean, G, mask, scale, tmp_scale) if (query_EFP_overflow_error()) call MOM_error(FATAL, & "global_j_mean overflow error occurred before sums across PEs.") - call EFP_list_sum_across_PEs(asum(G%isg:G%ieg), G%ieg-G%isg+1) - call EFP_list_sum_across_PEs(mask_sum(G%isg:G%ieg), G%ieg-G%isg+1) + call EFP_sum_across_PEs(asum(G%isg:G%ieg), G%ieg-G%isg+1) + call EFP_sum_across_PEs(mask_sum(G%isg:G%ieg), G%ieg-G%isg+1) if (query_EFP_overflow_error()) call MOM_error(FATAL, & "global_j_mean overflow error occurred during sums across PEs.") @@ -346,7 +347,7 @@ subroutine global_j_mean(array, j_mean, G, mask, scale, tmp_scale) if (query_EFP_overflow_error()) call MOM_error(FATAL, & "global_j_mean overflow error occurred before sum across PEs.") - call EFP_list_sum_across_PEs(asum(G%isg:G%ieg), G%ieg-G%isg+1) + call EFP_sum_across_PEs(asum(G%isg:G%ieg), G%ieg-G%isg+1) if (query_EFP_overflow_error()) call MOM_error(FATAL, & "global_j_mean overflow error occurred during sum across PEs.") @@ -369,8 +370,9 @@ subroutine adjust_area_mean_to_zero(array, G, scaling, unit_scale) real, optional, intent(out) :: scaling !< The scaling factor used real, optional, intent(in) :: unit_scale !< A rescaling factor for the variable ! Local variables - real, dimension(SZI_(G), SZJ_(G)) :: posVals, negVals, areaXposVals, areaXnegVals + real, dimension(G%isc:G%iec, G%jsc:G%jec) :: posVals, negVals, areaXposVals, areaXnegVals integer :: i,j + type(EFP_type), dimension(2) :: areaInt_EFP real :: scalefac ! A scaling factor for the variable. real :: I_scalefac ! The Adcroft reciprocal of scalefac real :: areaIntPosVals, areaIntNegVals, posScale, negScale @@ -378,8 +380,8 @@ subroutine adjust_area_mean_to_zero(array, G, scaling, unit_scale) scalefac = 1.0 ; if (present(unit_scale)) scalefac = unit_scale I_scalefac = 0.0 ; if (scalefac /= 0.0) I_scalefac = 1.0 / scalefac - areaXposVals(:,:) = 0. - areaXnegVals(:,:) = 0. + ! areaXposVals(:,:) = 0. ! This zeros out halo points. + ! areaXnegVals(:,:) = 0. ! This zeros out halo points. do j=G%jsc,G%jec ; do i=G%isc,G%iec posVals(i,j) = max(0., scalefac*array(i,j)) @@ -388,8 +390,12 @@ subroutine adjust_area_mean_to_zero(array, G, scaling, unit_scale) areaXnegVals(i,j) = G%US%L_to_m**2*G%areaT(i,j) * negVals(i,j) enddo ; enddo - areaIntPosVals = reproducing_sum( areaXposVals ) - areaIntNegVals = reproducing_sum( areaXnegVals ) + ! Combining the sums like this avoids separate blocking global sums. + areaInt_EFP(1) = reproducing_sum_EFP( areaXposVals, only_on_PE=.true. ) + areaInt_EFP(2) = reproducing_sum_EFP( areaXnegVals, only_on_PE=.true. ) + call EFP_sum_across_PEs(areaInt_EFP, 2) + areaIntPosVals = EFP_to_real( areaInt_EFP(1) ) + areaIntNegVals = EFP_to_real( areaInt_EFP(2) ) posScale = 0.0 ; negScale = 0.0 if ((areaIntPosVals>0.).and.(areaIntNegVals<0.)) then ! Only adjust if possible From 3b0a2a682a53b24fa9ffda6f1aaa1f3d87f6d8d2 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 30 Apr 2020 07:10:41 -0400 Subject: [PATCH 243/316] Renamed all type(surface) variables to sfc_state Renamed all type(surface) variables to sfc_state, mostly from just state, for greater clarity and standardization within the MOM6 code. All answers are bitwise identical. --- src/core/MOM_checksum_packages.F90 | 35 +++++----- src/ice_shelf/MOM_ice_shelf.F90 | 88 +++++++++++++------------- src/tracer/DOME_tracer.F90 | 6 +- src/tracer/ISOMIP_tracer.F90 | 6 +- src/tracer/MOM_OCMIP2_CFC.F90 | 16 ++--- src/tracer/MOM_generic_tracer.F90 | 12 ++-- src/tracer/MOM_tracer_flow_control.F90 | 28 ++++---- src/tracer/advection_test_tracer.F90 | 6 +- src/tracer/boundary_impulse_tracer.F90 | 6 +- src/tracer/dye_example.F90 | 6 +- src/tracer/ideal_age_example.F90 | 6 +- src/tracer/oil_tracer.F90 | 6 +- src/tracer/pseudo_salt_tracer.F90 | 4 +- src/tracer/tracer_example.F90 | 6 +- src/user/BFB_surface_forcing.F90 | 13 ++-- src/user/Idealized_Hurricane.F90 | 40 ++++++------ src/user/SCM_CVMix_tests.F90 | 8 +-- src/user/dumbbell_surface_forcing.F90 | 16 ++--- src/user/user_revise_forcing.F90 | 4 +- 19 files changed, 155 insertions(+), 157 deletions(-) diff --git a/src/core/MOM_checksum_packages.F90 b/src/core/MOM_checksum_packages.F90 index 5fb96c1c73..dfe34676a6 100644 --- a/src/core/MOM_checksum_packages.F90 +++ b/src/core/MOM_checksum_packages.F90 @@ -141,15 +141,15 @@ end subroutine MOM_thermo_chksum ! ============================================================================= !> Write out chksums for the ocean surface variables. -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 - !! data in this structure is intent out. - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. - 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 - !! computational domain. +subroutine MOM_surface_chksum(mesg, sfc_state, G, haloshift, symmetric) + character(len=*), intent(in) :: mesg !< A message that appears on the chksum lines. + type(surface), intent(inout) :: sfc_state !< transparent ocean surface state 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 !< The width of halos to check (default 0). + logical, optional, intent(in) :: symmetric !< If true, do checksums on the fully symmetric + !! computational domain. integer :: hs logical :: sym @@ -157,14 +157,15 @@ subroutine MOM_surface_chksum(mesg, sfc, G, haloshift, symmetric) sym = .false. ; if (present(symmetric)) sym = symmetric hs = 1 ; if (present(haloshift)) hs = haloshift - if (allocated(sfc%SST)) call hchksum(sfc%SST, mesg//" SST",G%HI,haloshift=hs) - if (allocated(sfc%SSS)) call hchksum(sfc%SSS, mesg//" SSS",G%HI,haloshift=hs) - if (allocated(sfc%sea_lev)) call hchksum(sfc%sea_lev, mesg//" sea_lev",G%HI,haloshift=hs) - if (allocated(sfc%Hml)) call hchksum(sfc%Hml, mesg//" Hml",G%HI,haloshift=hs) - if (allocated(sfc%u) .and. allocated(sfc%v)) & - call uvchksum(mesg//" SSU", sfc%u, sfc%v, G%HI, haloshift=hs, symmetric=sym) -! if (allocated(sfc%salt_deficit)) call hchksum(sfc%salt_deficit, mesg//" salt deficit",G%HI,haloshift=hs) - if (allocated(sfc%frazil)) call hchksum(sfc%frazil, mesg//" frazil", G%HI, haloshift=hs) + if (allocated(sfc_state%SST)) call hchksum(sfc_state%SST, mesg//" SST", G%HI, haloshift=hs) + if (allocated(sfc_state%SSS)) call hchksum(sfc_state%SSS, mesg//" SSS", G%HI, haloshift=hs) + if (allocated(sfc_state%sea_lev)) call hchksum(sfc_state%sea_lev, mesg//" sea_lev", G%HI, haloshift=hs) + if (allocated(sfc_state%Hml)) call hchksum(sfc_state%Hml, mesg//" Hml", G%HI, haloshift=hs) + if (allocated(sfc_state%u) .and. allocated(sfc_state%v)) & + call uvchksum(mesg//" SSU", sfc_state%u, sfc_state%v, G%HI, haloshift=hs, symmetric=sym) +! if (allocated(sfc_state%salt_deficit)) & +! call hchksum(sfc_state%salt_deficit, mesg//" salt deficit", G%HI, haloshift=hs) + if (allocated(sfc_state%frazil)) call hchksum(sfc_state%frazil, mesg//" frazil", G%HI, haloshift=hs) end subroutine MOM_surface_chksum diff --git a/src/ice_shelf/MOM_ice_shelf.F90 b/src/ice_shelf/MOM_ice_shelf.F90 index 0db52e57e5..819ce8bb76 100644 --- a/src/ice_shelf/MOM_ice_shelf.F90 +++ b/src/ice_shelf/MOM_ice_shelf.F90 @@ -192,8 +192,8 @@ module MOM_ice_shelf !> 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, fluxes, Time, time_step, CS, forces) - type(surface), intent(inout) :: state !< A structure containing fields that +subroutine shelf_calc_flux(sfc_state, fluxes, Time, time_step, CS, forces) + type(surface), intent(inout) :: sfc_state !< A structure containing fields that !! describe the surface state of the ocean. The !! intent is only inout to allow for halo updates. type(forcing), intent(inout) :: fluxes !< structure containing pointers to any possible @@ -319,7 +319,7 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) 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. haline_driving(:,:) = 0.0 - Sbdry(:,:) = state%sss(:,:) + Sbdry(:,:) = sfc_state%sss(:,:) !update time CS%Time = Time @@ -332,16 +332,16 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) 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) + call hchksum(sfc_state%sst, "sst before apply melting", G%HI, haloshift=0) + call hchksum(sfc_state%sss, "sss before apply melting", G%HI, haloshift=0) + call hchksum(sfc_state%u, "u_ml before apply melting", G%HI, haloshift=0) + call hchksum(sfc_state%v, "v_ml before apply melting", G%HI, haloshift=0) + call hchksum(sfc_state%ocean_mass, "ocean_mass before apply melting", G%HI, haloshift=0) endif ! Calculate the friction velocity under ice shelves, using taux_shelf and tauy_shelf if possible. - if (allocated(state%taux_shelf) .and. allocated(state%tauy_shelf)) then - call pass_vector(state%taux_shelf, state%tauy_shelf, G%domain, TO_ALL, CGRID_NE) + if (allocated(sfc_state%taux_shelf) .and. allocated(sfc_state%tauy_shelf)) then + call pass_vector(sfc_state%taux_shelf, sfc_state%tauy_shelf, G%domain, TO_ALL, CGRID_NE) endif Irho0 = US%m_s_to_L_T**2*US%kg_m3_to_R / CS%Rho_ocn do j=js,je ; do i=is,ie ; if (fluxes%frac_shelf_h(i,j) > 0.0) then @@ -352,12 +352,12 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) asv2 = (ISS%area_shelf_h(i,j) + ISS%area_shelf_h(i,j+1)) I_au = 0.0 ; if (asu1 + asu2 > 0.0) I_au = 1.0 / (asu1 + asu2) I_av = 0.0 ; if (asv1 + asv2 > 0.0) I_av = 1.0 / (asv1 + asv2) - if (allocated(state%taux_shelf) .and. allocated(state%tauy_shelf)) then - taux2 = (asu1 * state%taux_shelf(I-1,j)**2 + asu2 * state%taux_shelf(I,j)**2 ) * I_au - tauy2 = (asv1 * state%tauy_shelf(i,J-1)**2 + asv2 * state%tauy_shelf(i,J)**2 ) * I_av + if (allocated(sfc_state%taux_shelf) .and. allocated(sfc_state%tauy_shelf)) then + taux2 = (asu1 * sfc_state%taux_shelf(I-1,j)**2 + asu2 * sfc_state%taux_shelf(I,j)**2 ) * I_au + tauy2 = (asv1 * sfc_state%tauy_shelf(i,J-1)**2 + asv2 * sfc_state%tauy_shelf(i,J)**2 ) * I_av endif - u2_av = US%m_s_to_L_T**2*(asu1 * state%u(I-1,j)**2 + asu2 * state%u(I,j)**2) * I_au - v2_av = US%m_s_to_L_T**2*(asv1 * state%v(i,J-1)**2 + asu2 * state%v(i,J)**2) * I_av + u2_av = US%m_s_to_L_T**2*(asu1 * sfc_state%u(I-1,j)**2 + asu2 * sfc_state%u(I,j)**2) * I_au + v2_av = US%m_s_to_L_T**2*(asv1 * sfc_state%v(i,J-1)**2 + asu2 * sfc_state%v(i,J)**2) * I_av if (taux2 + tauy2 > 0.0) then fluxes%ustar_shelf(i,j) = MAX(CS%ustar_bg, US%L_to_Z * & @@ -377,13 +377,13 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) 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, Rhoml(:), & + call calculate_density(sfc_state%sst(:,j), sfc_state%sss(:,j), p_int, Rhoml(:), & CS%eqn_of_state, EOSdom) - call calculate_density_derivs(state%sst(:,j), state%sss(:,j), p_int, dR0_dT, dR0_dS, & + call calculate_density_derivs(sfc_state%sst(:,j), sfc_state%sss(:,j), p_int, dR0_dT, dR0_dS, & CS%eqn_of_state, EOSdom) do i=is,ie - if ((state%ocean_mass(i,j) > US%RZ_to_kg_m2*CS%col_mass_melt_threshold) .and. & + if ((sfc_state%ocean_mass(i,j) > US%RZ_to_kg_m2*CS%col_mass_melt_threshold) .and. & (ISS%area_shelf_h(i,j) > 0.0) .and. CS%isthermo) then if (CS%threeeq) then @@ -397,7 +397,7 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) ! reported ocean mixed layer thickness and the neutral Ekman depth. absf = 0.25*((abs(G%CoriolisBu(I,J)) + abs(G%CoriolisBu(I-1,J-1))) + & (abs(G%CoriolisBu(I,J-1)) + abs(G%CoriolisBu(I-1,J)))) - if (absf*US%m_to_Z*state%Hml(i,j) <= VK*ustar_h) then ; hBL_neut = US%m_to_Z*state%Hml(i,j) + if (absf*US%m_to_Z*sfc_state%Hml(i,j) <= VK*ustar_h) then ; hBL_neut = US%m_to_Z*sfc_state%Hml(i,j) else ; hBL_neut = (VK*ustar_h) / absf ; endif hBL_neut_h_molec = ZETA_N * ((hBL_neut * ustar_h) / (5.0 * CS%kv_molec)) @@ -414,9 +414,9 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) ! S_a is always < 0.0 with a realistic expression for the freezing point. S_a = CS%dTFr_dS * CS%Gamma_T_3EQ * CS%Cp - S_b = CS%Gamma_T_3EQ*CS%Cp*(CS%TFr_0_0 + CS%dTFr_dp*p_int(i) - state%sst(i,j)) - & + S_b = CS%Gamma_T_3EQ*CS%Cp*(CS%TFr_0_0 + CS%dTFr_dp*p_int(i) - sfc_state%sst(i,j)) - & CS%Lat_fusion * CS%Gamma_S_3EQ ! S_b Can take either sign, but is usually negative. - S_c = CS%Lat_fusion * CS%Gamma_S_3EQ * state%sss(i,j) ! Always >= 0 + S_c = CS%Lat_fusion * CS%Gamma_S_3EQ * sfc_state%sss(i,j) ! Always >= 0 if (S_c == 0.0) then ! The solution for fresh water. Sbdry(i,j) = 0.0 @@ -434,7 +434,7 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) ! Safety check if (Sbdry(i,j) < 0.) then - write(mesg,*) 'state%sss(i,j) = ',state%sss(i,j), 'S_a, S_b, S_c', S_a, S_b, S_c + write(mesg,*) 'sfc_state%sss(i,j) = ',sfc_state%sss(i,j), 'S_a, S_b, S_c', S_a, S_b, S_c call MOM_error(WARNING, mesg, .true.) write(mesg,*) 'I,J,Sbdry1,Sbdry2',i,j,Sbdry1,Sbdry2 call MOM_error(WARNING, mesg, .true.) @@ -442,7 +442,7 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) endif else ! Guess sss as the iteration starting point for the boundary salinity. - Sbdry(i,j) = state%sss(i,j) ; Sb_max_set = .false. + Sbdry(i,j) = sfc_state%sss(i,j) ; Sb_max_set = .false. Sb_min_set = .false. endif !find_salt_root @@ -451,8 +451,8 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) call calculate_TFreeze(Sbdry(i,j), p_int(i), ISS%tfreeze(i,j), CS%eqn_of_state, & pres_scale=US%RL2_T2_to_Pa) - dT_ustar = (ISS%tfreeze(i,j) - state%sst(i,j)) * ustar_h - dS_ustar = (Sbdry(i,j) - state%sss(i,j)) * ustar_h + dT_ustar = (ISS%tfreeze(i,j) - sfc_state%sst(i,j)) * ustar_h + dS_ustar = (Sbdry(i,j) - sfc_state%sss(i,j)) * ustar_h ! First, determine the buoyancy flux assuming no effects of stability ! on the turbulence. Following H & J '99, this limit also applies @@ -558,10 +558,10 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) else mass_exch = exch_vel_s(i,j) * CS%Rho_ocn - Sbdry_it = (state%sss(i,j) * mass_exch + CS%Salin_ice * ISS%water_flux(i,j)) / & + Sbdry_it = (sfc_state%sss(i,j) * mass_exch + CS%Salin_ice * 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 + if (abs(dS_it) < 1.0e-4*(0.5*(sfc_state%sss(i,j) + Sbdry(i,j) + 1.0e-10))) exit if (dS_it < 0.0) then ! Sbdry is now the upper bound. @@ -592,11 +592,11 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) ! 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), ISS%tfreeze(i,j), CS%eqn_of_state, & + call calculate_TFreeze(sfc_state%sss(i,j), p_int(i), ISS%tfreeze(i,j), CS%eqn_of_state, & pres_scale=US%RL2_T2_to_Pa) exch_vel_t(i,j) = CS%gamma_t - ISS%tflux_ocn(i,j) = RhoCp * exch_vel_t(i,j) * (ISS%tfreeze(i,j) - state%sst(i,j)) + ISS%tflux_ocn(i,j) = RhoCp * exch_vel_t(i,j) * (ISS%tfreeze(i,j) - sfc_state%sst(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 @@ -607,7 +607,7 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) ISS%tflux_ocn(i,j) = 0.0 endif -! haline_driving(:,:) = state%sss(i,j) - Sbdry(i,j) +! haline_driving(:,:) = sfc_state%sss(i,j) - Sbdry(i,j) enddo ! i-loop enddo ! j-loop @@ -616,7 +616,7 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) fluxes%iceshelf_melt(:,:) = ISS%water_flux(:,:) * CS%flux_factor do j=js,je ; do i=is,ie - if ((state%ocean_mass(i,j) > US%RZ_to_kg_m2*CS%col_mass_melt_threshold) .and. & + if ((sfc_state%ocean_mass(i,j) > US%RZ_to_kg_m2*CS%col_mass_melt_threshold) .and. & (ISS%area_shelf_h(i,j) > 0.0) .and. (CS%isthermo)) then ! Set melt to zero above a cutoff pressure (CS%Rho_ocn*CS%cutoff_depth*CS%g_Earth). @@ -630,11 +630,11 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) !!!!!!!!!!!!!!!!!!!!!!!!!!!!Safety checks !!!!!!!!!!!!!!!!!!!!!!!!! !1)Check if haline_driving computed above is consistent with - ! haline_driving = state%sss - Sbdry + ! haline_driving = sfc_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 + ! if (haline_driving(i,j) /= (sfc_state%sss(i,j) - Sbdry(i,j))) then ! write(mesg,*) 'at i,j=',i,j,' haline_driving, sss-Sbdry',haline_driving(i,j), & - ! (state%sss(i,j) - Sbdry(i,j)) + ! (sfc_state%sss(i,j) - Sbdry(i,j)) ! call MOM_error(FATAL, & ! "shelf_calc_flux: Inconsistency in melt and haline_driving"//trim(mesg)) ! endif @@ -679,7 +679,7 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) if (CS%debug) call MOM_forcing_chksum("Before add shelf flux", fluxes, G, CS%US, haloshift=0) - call add_shelf_flux(G, US, CS, state, fluxes) + call add_shelf_flux(G, US, CS, sfc_state, fluxes) ! now the thermodynamic data is passed on... time to update the ice dynamic quantities @@ -690,7 +690,7 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) ! 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, US, US%s_to_T*time_step, Time, & - US%kg_m3_to_R*US%m_to_Z*state%ocean_mass(:,:), coupled_GL) + US%kg_m3_to_R*US%m_to_Z*sfc_state%ocean_mass(:,:), coupled_GL) endif @@ -699,12 +699,12 @@ subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) 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_thermal_driving > 0) call post_data(CS%id_thermal_driving, (sfc_state%sst-ISS%tfreeze), CS%diag) if (CS%id_Sbdry > 0) call post_data(CS%id_Sbdry, Sbdry, CS%diag) 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_u_ml > 0) call post_data(CS%id_u_ml, sfc_state%u, CS%diag) + if (CS%id_v_ml > 0) call post_data(CS%id_v_ml, sfc_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) @@ -882,11 +882,11 @@ subroutine add_shelf_pressure(G, US, CS, fluxes) end subroutine add_shelf_pressure !> Updates surface fluxes that are influenced by sub-ice-shelf melting -subroutine add_shelf_flux(G, US, CS, state, fluxes) +subroutine add_shelf_flux(G, US, CS, sfc_state, fluxes) type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(ice_shelf_CS), pointer :: CS !< This module's control structure. - type(surface), intent(inout) :: state!< Surface ocean state + type(surface), intent(inout) :: sfc_state !< Surface ocean state type(forcing), intent(inout) :: fluxes !< A structure of surface fluxes that may be used/updated. ! local variables @@ -931,8 +931,8 @@ subroutine add_shelf_flux(G, US, CS, state, fluxes) ! vertical decay scale. if (CS%debug) then - if (allocated(state%taux_shelf) .and. allocated(state%tauy_shelf)) then - call uvchksum("tau[xy]_shelf", state%taux_shelf, state%tauy_shelf, & + if (allocated(sfc_state%taux_shelf) .and. allocated(sfc_state%tauy_shelf)) then + call uvchksum("tau[xy]_shelf", sfc_state%taux_shelf, sfc_state%tauy_shelf, & G%HI, haloshift=0) endif endif @@ -1023,7 +1023,7 @@ subroutine add_shelf_flux(G, US, CS, state, fluxes) ! get total ice shelf mass at (Time-dt) and (Time), in kg do j=js,je ; do i=is,ie ! Just consider the change in the mass of the floating shelf. - if ((state%ocean_mass(i,j) > US%RZ_to_kg_m2*CS%min_ocean_mass_float) .and. & + if ((sfc_state%ocean_mass(i,j) > US%RZ_to_kg_m2*CS%min_ocean_mass_float) .and. & (ISS%area_shelf_h(i,j) > 0.0)) then delta_float_mass(i,j) = ISS%mass_shelf(i,j) - last_mass_shelf(i,j) else diff --git a/src/tracer/DOME_tracer.F90 b/src/tracer/DOME_tracer.F90 index f8bc58c8d8..7396a4092a 100644 --- a/src/tracer/DOME_tracer.F90 +++ b/src/tracer/DOME_tracer.F90 @@ -338,9 +338,9 @@ end subroutine DOME_tracer_column_physics !> This subroutine extracts the surface fields from this tracer package that !! are to be shared with the atmosphere in coupled configurations. !! This particular tracer package does not report anything back to the coupler. -subroutine DOME_tracer_surface_state(state, h, G, CS) +subroutine DOME_tracer_surface_state(sfc_state, h, G, CS) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. - type(surface), intent(inout) :: state !< A structure containing fields that + type(surface), intent(inout) :: sfc_state !< A structure containing fields that !! describe the surface state of the ocean. real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & intent(in) :: h !< Layer thickness [H ~> m or kg m-2]. @@ -361,7 +361,7 @@ subroutine DOME_tracer_surface_state(state, h, G, CS) ! This call loads the surface values into the appropriate array in the ! coupler-type structure. call coupler_type_set_data(CS%tr(:,:,1,m), CS%ind_tr(m), ind_csurf, & - state%tr_fields, idim=(/isd, is, ie, ied/), & + sfc_state%tr_fields, idim=(/isd, is, ie, ied/), & jdim=(/jsd, js, je, jed/) ) enddo endif diff --git a/src/tracer/ISOMIP_tracer.F90 b/src/tracer/ISOMIP_tracer.F90 index 95d451791e..c9bf98f7ff 100644 --- a/src/tracer/ISOMIP_tracer.F90 +++ b/src/tracer/ISOMIP_tracer.F90 @@ -325,9 +325,9 @@ end subroutine ISOMIP_tracer_column_physics !> This subroutine extracts the surface fields from this tracer package that !! are to be shared with the atmosphere in coupled configurations. !! This particular tracer package does not report anything back to the coupler. -subroutine ISOMIP_tracer_surface_state(state, h, G, CS) +subroutine ISOMIP_tracer_surface_state(sfc_state, h, G, CS) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. - type(surface), intent(inout) :: state !< A structure containing fields that + type(surface), intent(inout) :: sfc_state !< A structure containing fields that !! describe the surface state of the ocean. real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & intent(in) :: h !< Layer thickness [H ~> m or kg m-2]. @@ -348,7 +348,7 @@ subroutine ISOMIP_tracer_surface_state(state, h, G, CS) ! This call loads the surface values into the appropriate array in the ! coupler-type structure. call coupler_type_set_data(CS%tr(:,:,1,m), CS%ind_tr(m), ind_csurf, & - state%tr_fields, idim=(/isd, is, ie, ied/), & + sfc_state%tr_fields, idim=(/isd, is, ie, ied/), & jdim=(/jsd, js, je, jed/) ) enddo endif diff --git a/src/tracer/MOM_OCMIP2_CFC.F90 b/src/tracer/MOM_OCMIP2_CFC.F90 index a95ea654f4..9aad84a6dd 100644 --- a/src/tracer/MOM_OCMIP2_CFC.F90 +++ b/src/tracer/MOM_OCMIP2_CFC.F90 @@ -542,9 +542,9 @@ end function OCMIP2_CFC_stock !> This subroutine extracts the surface CFC concentrations and other fields that !! are shared with the atmosphere to calculate CFC fluxes. -subroutine OCMIP2_CFC_surface_state(state, h, G, CS) +subroutine OCMIP2_CFC_surface_state(sfc_state, h, G, CS) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. - type(surface), intent(inout) :: state !< A structure containing fields that + type(surface), intent(inout) :: sfc_state !< A structure containing fields that !! describe the surface state of the ocean. real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & intent(in) :: h !< Layer thickness [H ~> m or kg m-2]. @@ -572,8 +572,8 @@ subroutine OCMIP2_CFC_surface_state(state, h, G, CS) if (.not.associated(CS)) return do j=js,je ; do i=is,ie - ta = max(0.01, (state%SST(i,j) + 273.15) * 0.01) ! Why is this in hectoKelvin? - sal = state%SSS(i,j) ; SST = state%SST(i,j) + ta = max(0.01, (sfc_state%SST(i,j) + 273.15) * 0.01) ! Why is this in hectoKelvin? + sal = sfc_state%SSS(i,j) ; SST = sfc_state%SST(i,j) ! Calculate solubilities using Warner and Weiss (1985) DSR, vol 32. ! The final result is in mol/cm3/pptv (1 part per trillion 1e-12) ! Use Bullister and Wisegavger for CCl4. @@ -603,13 +603,13 @@ subroutine OCMIP2_CFC_surface_state(state, h, G, CS) ! These calls load these values into the appropriate arrays in the ! coupler-type structure. call coupler_type_set_data(CFC11_alpha, CS%ind_cfc_11_flux, ind_alpha, & - state%tr_fields, idim=idim, jdim=jdim) + sfc_state%tr_fields, idim=idim, jdim=jdim) call coupler_type_set_data(CFC11_Csurf, CS%ind_cfc_11_flux, ind_csurf, & - state%tr_fields, idim=idim, jdim=jdim) + sfc_state%tr_fields, idim=idim, jdim=jdim) call coupler_type_set_data(CFC12_alpha, CS%ind_cfc_12_flux, ind_alpha, & - state%tr_fields, idim=idim, jdim=jdim) + sfc_state%tr_fields, idim=idim, jdim=jdim) call coupler_type_set_data(CFC12_Csurf, CS%ind_cfc_12_flux, ind_csurf, & - state%tr_fields, idim=idim, jdim=jdim) + sfc_state%tr_fields, idim=idim, jdim=jdim) end subroutine OCMIP2_CFC_surface_state diff --git a/src/tracer/MOM_generic_tracer.F90 b/src/tracer/MOM_generic_tracer.F90 index 83c2c9a8e7..e68833c3cd 100644 --- a/src/tracer/MOM_generic_tracer.F90 +++ b/src/tracer/MOM_generic_tracer.F90 @@ -706,9 +706,9 @@ end function MOM_generic_tracer_min_max !! !! This subroutine sets up the fields that the coupler needs to calculate the !! CFC fluxes between the ocean and atmosphere. - subroutine MOM_generic_tracer_surface_state(state, h, G, CS) + subroutine MOM_generic_tracer_surface_state(sfc_state, h, G, CS) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - type(surface), intent(inout) :: state !< A structure containing fields that + type(surface), intent(inout) :: sfc_state !< A structure containing fields that !! describe the surface state of the ocean. real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] type(MOM_generic_tracer_CS), pointer :: CS !< Pointer to the control structure for this module. @@ -727,11 +727,11 @@ subroutine MOM_generic_tracer_surface_state(state, h, G, CS) dzt(:,:,:) = CS%H_to_m * h(:,:,:) - sosga = global_area_mean(state%SSS, G) + sosga = global_area_mean(sfc_state%SSS, G) - call generic_tracer_coupler_set(state%tr_fields,& - ST=state%SST,& - SS=state%SSS,& + call generic_tracer_coupler_set(sfc_state%tr_fields,& + ST=sfc_state%SST,& + SS=sfc_state%SSS,& rho=rho0,& !nnz: required for MOM5 and previous versions. ilb=G%isd, jlb=G%jsd,& dzt=dzt,& !This is needed for the Mocsy method of carbonate system vars diff --git a/src/tracer/MOM_tracer_flow_control.F90 b/src/tracer/MOM_tracer_flow_control.F90 index 6e28477d26..86003605f7 100644 --- a/src/tracer/MOM_tracer_flow_control.F90 +++ b/src/tracer/MOM_tracer_flow_control.F90 @@ -378,9 +378,9 @@ end subroutine get_chl_from_model !> This subroutine calls the individual tracer modules' subroutines to !! specify or read quantities related to their surface forcing. -subroutine call_tracer_set_forcing(state, fluxes, day_start, day_interval, G, CS) +subroutine call_tracer_set_forcing(sfc_state, fluxes, day_start, day_interval, G, CS) - type(surface), intent(inout) :: state !< A structure containing fields that + 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 pointers to any @@ -396,7 +396,7 @@ subroutine call_tracer_set_forcing(state, fluxes, day_start, day_interval, G, CS if (.not. associated(CS)) call MOM_error(FATAL, "call_tracer_set_forcing"// & "Module must be initialized via call_tracer_register before it is used.") ! if (CS%use_ideal_age) & -! call ideal_age_tracer_set_forcing(state, fluxes, day_start, day_interval, & +! call ideal_age_tracer_set_forcing(sfc_state, fluxes, day_start, day_interval, & ! G, CS%ideal_age_tracer_CSp) end subroutine call_tracer_set_forcing @@ -755,8 +755,8 @@ end subroutine store_stocks !> 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_surface_state(state, h, G, CS) - type(surface), intent(inout) :: state !< A structure containing fields that +subroutine call_tracer_surface_state(sfc_state, h, G, CS) + type(surface), intent(inout) :: sfc_state !< A structure containing fields that !! describe the surface state of the ocean. real, dimension(NIMEM_,NJMEM_,NKMEM_), & intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] @@ -769,24 +769,24 @@ subroutine call_tracer_surface_state(state, h, G, CS) ! Add other user-provided calls here. if (CS%use_USER_tracer_example) & - call USER_tracer_surface_state(state, h, G, CS%USER_tracer_example_CSp) + call USER_tracer_surface_state(sfc_state, h, G, CS%USER_tracer_example_CSp) if (CS%use_DOME_tracer) & - call DOME_tracer_surface_state(state, h, G, CS%DOME_tracer_CSp) + call DOME_tracer_surface_state(sfc_state, h, G, CS%DOME_tracer_CSp) if (CS%use_ISOMIP_tracer) & - call ISOMIP_tracer_surface_state(state, h, G, CS%ISOMIP_tracer_CSp) + call ISOMIP_tracer_surface_state(sfc_state, h, G, CS%ISOMIP_tracer_CSp) if (CS%use_ideal_age) & - call ideal_age_tracer_surface_state(state, h, G, CS%ideal_age_tracer_CSp) + call ideal_age_tracer_surface_state(sfc_state, h, G, CS%ideal_age_tracer_CSp) if (CS%use_regional_dyes) & - call dye_tracer_surface_state(state, h, G, CS%dye_tracer_CSp) + call dye_tracer_surface_state(sfc_state, h, G, CS%dye_tracer_CSp) if (CS%use_oil) & - call oil_tracer_surface_state(state, h, G, CS%oil_tracer_CSp) + call oil_tracer_surface_state(sfc_state, h, G, CS%oil_tracer_CSp) if (CS%use_advection_test_tracer) & - call advection_test_tracer_surface_state(state, h, G, CS%advection_test_tracer_CSp) + call advection_test_tracer_surface_state(sfc_state, h, G, CS%advection_test_tracer_CSp) if (CS%use_OCMIP2_CFC) & - call OCMIP2_CFC_surface_state(state, h, G, CS%OCMIP2_CFC_CSp) + call OCMIP2_CFC_surface_state(sfc_state, h, G, CS%OCMIP2_CFC_CSp) #ifdef _USE_GENERIC_TRACER if (CS%use_MOM_generic_tracer) & - call MOM_generic_tracer_surface_state(state, h, G, CS%MOM_generic_tracer_CSp) + call MOM_generic_tracer_surface_state(sfc_state, h, G, CS%MOM_generic_tracer_CSp) #endif end subroutine call_tracer_surface_state diff --git a/src/tracer/advection_test_tracer.F90 b/src/tracer/advection_test_tracer.F90 index 82ea38f22c..b1d657d6e2 100644 --- a/src/tracer/advection_test_tracer.F90 +++ b/src/tracer/advection_test_tracer.F90 @@ -316,9 +316,9 @@ end subroutine advection_test_tracer_column_physics !> This subroutine extracts the surface fields from this tracer package that !! are to be shared with the atmosphere in coupled configurations. !! This particular tracer package does not report anything back to the coupler. -subroutine advection_test_tracer_surface_state(state, h, G, CS) +subroutine advection_test_tracer_surface_state(sfc_state, h, G, CS) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. - type(surface), intent(inout) :: state !< A structure containing fields that + type(surface), intent(inout) :: sfc_state !< A structure containing fields that !! describe the surface state of the ocean. real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & intent(in) :: h !< Layer thickness [H ~> m or kg m-2]. @@ -339,7 +339,7 @@ subroutine advection_test_tracer_surface_state(state, h, G, CS) ! This call loads the surface values into the appropriate array in the ! coupler-type structure. call coupler_type_set_data(CS%tr(:,:,1,m), CS%ind_tr(m), ind_csurf, & - state%tr_fields, idim=(/isd, is, ie, ied/), & + sfc_state%tr_fields, idim=(/isd, is, ie, ied/), & jdim=(/jsd, js, je, jed/) ) enddo endif diff --git a/src/tracer/boundary_impulse_tracer.F90 b/src/tracer/boundary_impulse_tracer.F90 index e70320a5c7..da76cb3026 100644 --- a/src/tracer/boundary_impulse_tracer.F90 +++ b/src/tracer/boundary_impulse_tracer.F90 @@ -334,9 +334,9 @@ end function boundary_impulse_stock !> This subroutine extracts the surface fields from this tracer package that !! are to be shared with the atmosphere in coupled configurations. !! This particular tracer package does not report anything back to the coupler. -subroutine boundary_impulse_tracer_surface_state(state, h, G, CS) +subroutine boundary_impulse_tracer_surface_state(sfc_state, h, G, CS) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. - type(surface), intent(inout) :: state !< A structure containing fields that + type(surface), intent(inout) :: sfc_state !< A structure containing fields that !! describe the surface state of the ocean. real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & intent(in) :: h !< Layer thickness [H ~> m or kg m-2]. @@ -357,7 +357,7 @@ subroutine boundary_impulse_tracer_surface_state(state, h, G, CS) ! This call loads the surface values into the appropriate array in the ! coupler-type structure. call coupler_type_set_data(CS%tr(:,:,1,m), CS%ind_tr(m), ind_csurf, & - state%tr_fields, idim=(/isd, is, ie, ied/), & + sfc_state%tr_fields, idim=(/isd, is, ie, ied/), & jdim=(/jsd, js, je, jed/) ) enddo endif diff --git a/src/tracer/dye_example.F90 b/src/tracer/dye_example.F90 index 86a4ac7aeb..5f2f139899 100644 --- a/src/tracer/dye_example.F90 +++ b/src/tracer/dye_example.F90 @@ -372,9 +372,9 @@ end function dye_stock !> This subroutine extracts the surface fields from this tracer package that !! are to be shared with the atmosphere in coupled configurations. !! This particular tracer package does not report anything back to the coupler. -subroutine dye_tracer_surface_state(state, h, G, CS) +subroutine dye_tracer_surface_state(sfc_state, h, G, CS) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. - type(surface), intent(inout) :: state !< A structure containing fields that + type(surface), intent(inout) :: sfc_state !< A structure containing fields that !! describe the surface state of the ocean. real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & intent(in) :: h !< Layer thickness [H ~> m or kg m-2]. @@ -395,7 +395,7 @@ subroutine dye_tracer_surface_state(state, h, G, CS) ! This call loads the surface values into the appropriate array in the ! coupler-type structure. call coupler_type_set_data(CS%tr(:,:,1,m), CS%ind_tr(m), ind_csurf, & - state%tr_fields, idim=(/isd, is, ie, ied/), & + sfc_state%tr_fields, idim=(/isd, is, ie, ied/), & jdim=(/jsd, js, je, jed/) ) enddo endif diff --git a/src/tracer/ideal_age_example.F90 b/src/tracer/ideal_age_example.F90 index 3ef61e1a57..8f00b0d5b9 100644 --- a/src/tracer/ideal_age_example.F90 +++ b/src/tracer/ideal_age_example.F90 @@ -420,9 +420,9 @@ end function ideal_age_stock !> This subroutine extracts the surface fields from this tracer package that !! are to be shared with the atmosphere in coupled configurations. !! This particular tracer package does not report anything back to the coupler. -subroutine ideal_age_tracer_surface_state(state, h, G, CS) +subroutine ideal_age_tracer_surface_state(sfc_state, h, G, CS) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. - type(surface), intent(inout) :: state !< A structure containing fields that + type(surface), intent(inout) :: sfc_state !< A structure containing fields that !! describe the surface state of the ocean. real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & intent(in) :: h !< Layer thickness [H ~> m or kg m-2]. @@ -443,7 +443,7 @@ subroutine ideal_age_tracer_surface_state(state, h, G, CS) ! This call loads the surface values into the appropriate array in the ! coupler-type structure. call coupler_type_set_data(CS%tr(:,:,1,m), CS%ind_tr(m), ind_csurf, & - state%tr_fields, idim=(/isd, is, ie, ied/), & + sfc_state%tr_fields, idim=(/isd, is, ie, ied/), & jdim=(/jsd, js, je, jed/) ) enddo endif diff --git a/src/tracer/oil_tracer.F90 b/src/tracer/oil_tracer.F90 index 4d755497c6..c07f1c03e4 100644 --- a/src/tracer/oil_tracer.F90 +++ b/src/tracer/oil_tracer.F90 @@ -454,9 +454,9 @@ end function oil_stock !> This subroutine extracts the surface fields from this tracer package that !! are to be shared with the atmosphere in coupled configurations. !! This particular tracer package does not report anything back to the coupler. -subroutine oil_tracer_surface_state(state, h, G, CS) +subroutine oil_tracer_surface_state(sfc_state, h, G, CS) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. - type(surface), intent(inout) :: state !< A structure containing fields that + type(surface), intent(inout) :: sfc_state !< A structure containing fields that !! describe the surface state of the ocean. real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & intent(in) :: h !< Layer thickness [H ~> m or kg m-2]. @@ -477,7 +477,7 @@ subroutine oil_tracer_surface_state(state, h, G, CS) ! This call loads the surface values into the appropriate array in the ! coupler-type structure. call coupler_type_set_data(CS%tr(:,:,1,m), CS%ind_tr(m), ind_csurf, & - state%tr_fields, idim=(/isd, is, ie, ied/), & + sfc_state%tr_fields, idim=(/isd, is, ie, ied/), & jdim=(/jsd, js, je, jed/) ) enddo endif diff --git a/src/tracer/pseudo_salt_tracer.F90 b/src/tracer/pseudo_salt_tracer.F90 index 5c74487c0c..95396a3b58 100644 --- a/src/tracer/pseudo_salt_tracer.F90 +++ b/src/tracer/pseudo_salt_tracer.F90 @@ -299,9 +299,9 @@ end function pseudo_salt_stock !> This subroutine extracts the surface fields from this tracer package that !! are to be shared with the atmosphere in coupled configurations. !! This particular tracer package does not report anything back to the coupler. -subroutine pseudo_salt_tracer_surface_state(state, h, G, CS) +subroutine pseudo_salt_tracer_surface_state(sfc_state, h, G, CS) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. - type(surface), intent(inout) :: state !< A structure containing fields that + type(surface), intent(inout) :: sfc_state !< A structure containing fields that !! describe the surface state of the ocean. real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & intent(in) :: h !< Layer thickness [H ~> m or kg m-2]. diff --git a/src/tracer/tracer_example.F90 b/src/tracer/tracer_example.F90 index c5e8f669c6..ef16cc985d 100644 --- a/src/tracer/tracer_example.F90 +++ b/src/tracer/tracer_example.F90 @@ -405,9 +405,9 @@ end function USER_tracer_stock !> This subroutine extracts the surface fields from this tracer package that !! are to be shared with the atmosphere in coupled configurations. -subroutine USER_tracer_surface_state(state, h, G, CS) +subroutine USER_tracer_surface_state(sfc_state, h, G, CS) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - type(surface), intent(inout) :: state !< A structure containing fields that + type(surface), intent(inout) :: sfc_state !< A structure containing fields that !! describe the surface state of the ocean. real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] @@ -428,7 +428,7 @@ subroutine USER_tracer_surface_state(state, h, G, CS) ! This call loads the surface values into the appropriate array in the ! coupler-type structure. call coupler_type_set_data(CS%tr(:,:,1,m), CS%ind_tr(m), ind_csurf, & - state%tr_fields, idim=(/isd, is, ie, ied/), & + sfc_state%tr_fields, idim=(/isd, is, ie, ied/), & jdim=(/jsd, js, je, jed/) ) enddo endif diff --git a/src/user/BFB_surface_forcing.F90 b/src/user/BFB_surface_forcing.F90 index 70d89497da..a6aae3d3f7 100644 --- a/src/user/BFB_surface_forcing.F90 +++ b/src/user/BFB_surface_forcing.F90 @@ -47,8 +47,8 @@ module BFB_surface_forcing contains !> Bouyancy forcing for the boundary-forced-basin (BFB) configuration -subroutine BFB_buoyancy_forcing(state, fluxes, day, dt, G, US, CS) - type(surface), intent(inout) :: state !< A structure containing fields that +subroutine BFB_buoyancy_forcing(sfc_state, fluxes, day, dt, G, US, 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 pointers to any !! possible forcing fields. Unused fields @@ -136,9 +136,9 @@ subroutine BFB_buoyancy_forcing(state, fluxes, day, dt, G, US, CS) Salin_restore = 0.0 fluxes%heat_added(i,j) = (G%mask2dT(i,j) * (rhoXcp * CS%Flux_const)) * & - (Temp_restore - state%SST(i,j)) + (Temp_restore - sfc_state%SST(i,j)) fluxes%vprec(i,j) = - (G%mask2dT(i,j) * (CS%Rho0*CS%Flux_const)) * & - ((Salin_restore - state%SSS(i,j)) / (0.5 * (Salin_restore + state%SSS(i,j)))) + ((Salin_restore - sfc_state%SSS(i,j)) / (0.5 * (Salin_restore + sfc_state%SSS(i,j)))) enddo ; enddo else ! When modifying the code, comment out this error message. It is here @@ -164,7 +164,7 @@ subroutine BFB_buoyancy_forcing(state, fluxes, day, dt, G, US, CS) density_restore = Temp_restore*CS%drho_dt + CS%Rho0 fluxes%buoy(i,j) = G%mask2dT(i,j) * buoy_rest_const * & - (density_restore - US%kg_m3_to_R*state%sfc_density(i,j)) + (density_restore - US%kg_m3_to_R*sfc_state%sfc_density(i,j)) enddo ; enddo endif endif ! end RESTOREBUOY @@ -195,8 +195,7 @@ subroutine BFB_surface_forcing_init(Time, G, US, param_file, diag, CS) ! Read all relevant parameters and write them to the model log. call log_version(param_file, mdl, version, "") call get_param(param_file, mdl, "ENABLE_THERMODYNAMICS", CS%use_temperature, & - "If true, Temperature and salinity are used as state "//& - "variables.", default=.true.) + "If true, Temperature and salinity are used as state variables.", default=.true.) call get_param(param_file, mdl, "G_EARTH", CS%G_Earth, & "The gravitational acceleration of the Earth.", & diff --git a/src/user/Idealized_Hurricane.F90 b/src/user/Idealized_Hurricane.F90 index 38ba0ab460..5727309926 100644 --- a/src/user/Idealized_Hurricane.F90 +++ b/src/user/Idealized_Hurricane.F90 @@ -206,8 +206,8 @@ subroutine idealized_hurricane_wind_init(Time, G, US, param_file, CS) end subroutine idealized_hurricane_wind_init !> Computes the surface wind for the idealized hurricane test cases -subroutine idealized_hurricane_wind_forcing(state, forces, day, G, US, CS) - type(surface), intent(in) :: state !< Surface state structure +subroutine idealized_hurricane_wind_forcing(sfc_state, forces, day, G, US, CS) + type(surface), intent(in) :: sfc_state !< Surface state structure type(mech_forcing), intent(inout) :: forces !< A structure with the driving mechanical forces type(time_type), intent(in) :: day !< Time in days type(ocean_grid_type), intent(inout) :: G !< Grid structure @@ -263,13 +263,13 @@ subroutine idealized_hurricane_wind_forcing(state, forces, day, G, US, CS) !> Computes taux do j=js,je do I=is-1,Ieq - Uocn = US%m_s_to_L_T * state%u(I,j)*REL_TAU_FAC + Uocn = US%m_s_to_L_T * sfc_state%u(I,j)*REL_TAU_FAC if (CS%answers_2018) then - Vocn = US%m_s_to_L_T * 0.25*(state%v(i,J)+state%v(i+1,J-1)& - +state%v(i+1,J)+state%v(i,J-1))*REL_TAU_FAC + Vocn = US%m_s_to_L_T * 0.25*(sfc_state%v(i,J)+sfc_state%v(i+1,J-1)& + +sfc_state%v(i+1,J)+sfc_state%v(i,J-1))*REL_TAU_FAC else - Vocn = US%m_s_to_L_T * 0.25*((state%v(i,J)+state%v(i+1,J-1)) +& - (state%v(i+1,J)+state%v(i,J-1))) * REL_TAU_FAC + Vocn = US%m_s_to_L_T * 0.25*((sfc_state%v(i,J)+sfc_state%v(i+1,J-1)) +& + (sfc_state%v(i+1,J)+sfc_state%v(i,J-1))) * REL_TAU_FAC endif f_local = abs(0.5*(G%CoriolisBu(I,J)+G%CoriolisBu(I,J-1)))*fbench_fac + fbench ! Calculate position as a function of time. @@ -288,13 +288,13 @@ subroutine idealized_hurricane_wind_forcing(state, forces, day, G, US, CS) do J=js-1,Jeq do i=is,ie if (CS%answers_2018) then - Uocn = US%m_s_to_L_T * 0.25*(state%u(I,j)+state%u(I-1,j+1) + & - state%u(I-1,j)+state%u(I,j+1))*REL_TAU_FAC + Uocn = US%m_s_to_L_T * 0.25*(sfc_state%u(I,j)+sfc_state%u(I-1,j+1) + & + sfc_state%u(I-1,j)+sfc_state%u(I,j+1))*REL_TAU_FAC else - Uocn = US%m_s_to_L_T * 0.25*((state%u(I,j)+state%u(I-1,j+1)) + & - (state%u(I-1,j)+state%u(I,j+1))) * REL_TAU_FAC + Uocn = US%m_s_to_L_T * 0.25*((sfc_state%u(I,j)+sfc_state%u(I-1,j+1)) + & + (sfc_state%u(I-1,j)+sfc_state%u(I,j+1))) * REL_TAU_FAC endif - Vocn = US%m_s_to_L_T * state%v(i,J)*REL_TAU_FAC + Vocn = US%m_s_to_L_T * sfc_state%v(i,J)*REL_TAU_FAC f_local = abs(0.5*(G%CoriolisBu(I-1,J)+G%CoriolisBu(I,J)))*fbench_fac + fbench ! Calculate position as a function of time. if (CS%SCM_mode) then @@ -471,8 +471,8 @@ end subroutine idealized_hurricane_wind_profile !! It is included as an additional subroutine rather than padded into the previous !! routine with flags to ease its eventual removal. Its functionality is replaced !! with the new routines and it can be deleted when answer changes are acceptable. -subroutine SCM_idealized_hurricane_wind_forcing(state, forces, day, G, US, CS) - type(surface), intent(in) :: state !< Surface state structure +subroutine SCM_idealized_hurricane_wind_forcing(sfc_state, forces, day, G, US, CS) + type(surface), intent(in) :: sfc_state !< Surface state structure type(mech_forcing), intent(inout) :: forces !< A structure with the driving mechanical forces type(time_type), intent(in) :: day !< Time in days type(ocean_grid_type), intent(inout) :: G !< Grid structure @@ -604,9 +604,9 @@ subroutine SCM_idealized_hurricane_wind_forcing(state, forces, day, G, US, CS) !/BR ! Turn off surface current for stress calculation to be ! consistent with test case. - Uocn = 0. ! state%u(I,j) - Vocn = 0. ! 0.25*( (state%v(i,J) + state%v(i+1,J-1)) & - ! +(state%v(i+1,J) + state%v(i,J-1)) ) + Uocn = 0. ! sfc_state%u(I,j) + Vocn = 0. ! 0.25*( (sfc_state%v(i,J) + sfc_state%v(i+1,J-1)) + & + ! (sfc_state%v(i+1,J) + sfc_state%v(i,J-1)) ) !/BR ! Wind vector calculated from location/direction (sin/cos flipped b/c ! cyclonic wind is 90 deg. phase shifted from position angle). @@ -633,9 +633,9 @@ subroutine SCM_idealized_hurricane_wind_forcing(state, forces, day, G, US, CS) !/BR ! See notes above do J=js-1,Jeq ; do i=is,ie - Uocn = 0. ! 0.25*( (state%u(I,j) + state%u(I-1,j+1)) & - ! +(state%u(I-1,j) + state%u(I,j+1)) ) - Vocn = 0. ! state%v(i,J) + Uocn = 0. ! 0.25*( (sfc_state%u(I,j) + sfc_state%u(I-1,j+1)) + & + ! (sfc_state%u(I-1,j) + sfc_state%u(I,j+1)) ) + Vocn = 0. ! sfc_state%v(i,J) dU = U10*sin(Adir-pie-Alph) - Uocn + U_TS dV = U10*cos(Adir-Alph) - Vocn + V_TS du10=sqrt(du**2+dv**2) diff --git a/src/user/SCM_CVMix_tests.F90 b/src/user/SCM_CVMix_tests.F90 index a63205fede..1bb1b9555e 100644 --- a/src/user/SCM_CVMix_tests.F90 +++ b/src/user/SCM_CVMix_tests.F90 @@ -200,8 +200,8 @@ subroutine SCM_CVMix_tests_surface_forcing_init(Time, G, param_file, CS) end subroutine SCM_CVMix_tests_surface_forcing_init -subroutine SCM_CVMix_tests_wind_forcing(state, forces, day, G, US, CS) - type(surface), intent(in) :: state !< Surface state structure +subroutine SCM_CVMix_tests_wind_forcing(sfc_state, forces, day, G, US, CS) + type(surface), intent(in) :: sfc_state !< Surface state structure type(mech_forcing), intent(inout) :: forces !< A structure with the driving mechanical forces type(time_type), intent(in) :: day !< Time in days type(ocean_grid_type), intent(inout) :: G !< Grid structure @@ -233,8 +233,8 @@ subroutine SCM_CVMix_tests_wind_forcing(state, forces, day, G, US, CS) end subroutine SCM_CVMix_tests_wind_forcing -subroutine SCM_CVMix_tests_buoyancy_forcing(state, fluxes, day, G, US, CS) - type(surface), intent(in) :: state !< Surface state structure +subroutine SCM_CVMix_tests_buoyancy_forcing(sfc_state, fluxes, day, G, US, CS) + type(surface), intent(in) :: sfc_state !< Surface state structure type(forcing), intent(inout) :: fluxes !< Surface fluxes structure type(time_type), intent(in) :: day !< Current model time type(ocean_grid_type), intent(inout) :: G !< Grid structure diff --git a/src/user/dumbbell_surface_forcing.F90 b/src/user/dumbbell_surface_forcing.F90 index 5be2bc9b8e..4c582dd03e 100644 --- a/src/user/dumbbell_surface_forcing.F90 +++ b/src/user/dumbbell_surface_forcing.F90 @@ -24,8 +24,7 @@ module dumbbell_surface_forcing !> Control structure for the dumbbell test case forcing type, public :: dumbbell_surface_forcing_CS ; private - logical :: use_temperature !< If true, temperature and salinity are used as - !! state variables. + logical :: use_temperature !< If true, temperature and salinity are used as state variables. logical :: restorebuoy !< If true, use restoring surface buoyancy forcing. real :: Rho0 !< The density used in the Boussinesq approximation [R ~> kg m-3]. real :: G_Earth !< The gravitational acceleration [L2 Z-1 T-2 ~> m s-2] @@ -46,8 +45,8 @@ module dumbbell_surface_forcing contains !> Surface buoyancy (heat and fresh water) fluxes for the dumbbell test case -subroutine dumbbell_buoyancy_forcing(state, fluxes, day, dt, G, US, CS) - type(surface), intent(inout) :: state !< A structure containing fields that +subroutine dumbbell_buoyancy_forcing(sfc_state, fluxes, day, dt, G, US, 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 pointers to any !! possible forcing fields. Unused fields @@ -119,7 +118,7 @@ subroutine dumbbell_buoyancy_forcing(state, fluxes, day, dt, G, US, CS) do j=js,je ; do i=is,ie if (CS%forcing_mask(i,j)>0.) then fluxes%vprec(i,j) = - (G%mask2dT(i,j) * (CS%Rho0*CS%Flux_const)) * & - ((CS%S_restore(i,j) - state%SSS(i,j)) / (0.5 * (CS%S_restore(i,j) + state%SSS(i,j)))) + ((CS%S_restore(i,j) - sfc_state%SSS(i,j)) / (0.5 * (CS%S_restore(i,j) + sfc_state%SSS(i,j)))) endif enddo ; enddo @@ -128,8 +127,8 @@ subroutine dumbbell_buoyancy_forcing(state, fluxes, day, dt, G, US, CS) end subroutine dumbbell_buoyancy_forcing !> Dynamic forcing for the dumbbell test case -subroutine dumbbell_dynamic_forcing(state, fluxes, day, dt, G, CS) - type(surface), intent(inout) :: state !< A structure containing fields that +subroutine dumbbell_dynamic_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 !< A structure containing pointers to any !! possible forcing fields. Unused fields @@ -198,8 +197,7 @@ subroutine dumbbell_surface_forcing_init(Time, G, US, param_file, diag, CS) ! Read all relevant parameters and write them to the model log. call log_version(param_file, mdl, version, "") call get_param(param_file, mdl, "ENABLE_THERMODYNAMICS", CS%use_temperature, & - "If true, Temperature and salinity are used as state "//& - "variables.", default=.true.) + "If true, Temperature and salinity are used as state variables.", default=.true.) call get_param(param_file, mdl, "G_EARTH", CS%G_Earth, & "The gravitational acceleration of the Earth.", & diff --git a/src/user/user_revise_forcing.F90 b/src/user/user_revise_forcing.F90 index d1be729734..c53451f4e8 100644 --- a/src/user/user_revise_forcing.F90 +++ b/src/user/user_revise_forcing.F90 @@ -30,8 +30,8 @@ module user_revise_forcing contains !> This subroutine sets the surface wind stresses. -subroutine user_alter_forcing(state, fluxes, day, G, CS) - type(surface), intent(in) :: state !< A structure containing fields that +subroutine user_alter_forcing(sfc_state, fluxes, day, G, CS) + type(surface), intent(in) :: sfc_state !< A structure containing fields that !! describe the surface state of the ocean. type(forcing), intent(inout) :: fluxes !< A structure containing pointers to any !! possible forcing fields. Unused fields From c6321d642e1781ad7b527d490af4749b26a6d36c Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 30 Apr 2020 08:21:35 -0400 Subject: [PATCH 244/316] +Rescaled sfc_state%u and sfc_state%v Dimensionally rescaled the surface velocity variables to [L T-1]. All answers are bitwise identical, but the units of two elements in a transparent type have changed. --- config_src/coupled_driver/ocean_model_MOM.F90 | 12 +++++------ config_src/mct_driver/mom_ocean_model_mct.F90 | 12 +++++------ .../nuopc_driver/mom_ocean_model_nuopc.F90 | 12 +++++------ src/core/MOM.F90 | 20 +++++++++---------- src/core/MOM_checksum_packages.F90 | 3 ++- src/core/MOM_variables.F90 | 4 ++-- src/diagnostics/MOM_diagnostics.F90 | 14 ++++++------- src/ice_shelf/MOM_ice_shelf.F90 | 12 +++++------ src/user/Idealized_Hurricane.F90 | 20 +++++++++---------- 9 files changed, 55 insertions(+), 54 deletions(-) diff --git a/config_src/coupled_driver/ocean_model_MOM.F90 b/config_src/coupled_driver/ocean_model_MOM.F90 index 407a11a0c3..28ac193d8d 100644 --- a/config_src/coupled_driver/ocean_model_MOM.F90 +++ b/config_src/coupled_driver/ocean_model_MOM.F90 @@ -880,22 +880,22 @@ subroutine convert_state_to_ocean_type(sfc_state, Ocean_sfc, G, US, patm, press_ 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) * & + Ocean_sfc%u_surf(i,j) = G%mask2dT(i+i0,j+j0) * US%L_T_to_m_s * & 0.5*(sfc_state%u(I+i0,j+j0)+sfc_state%u(I-1+i0,j+j0)) - Ocean_sfc%v_surf(i,j) = G%mask2dT(i+i0,j+j0) * & + Ocean_sfc%v_surf(i,j) = G%mask2dT(i+i0,j+j0) * US%L_T_to_m_s * & 0.5*(sfc_state%v(i+i0,J+j0)+sfc_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) * & + Ocean_sfc%u_surf(i,j) = G%mask2dBu(I+i0,J+j0) * US%L_T_to_m_s * & 0.5*(sfc_state%u(I+i0,j+j0)+sfc_state%u(I+i0,j+j0+1)) - Ocean_sfc%v_surf(i,j) = G%mask2dBu(I+i0,J+j0) * & + Ocean_sfc%v_surf(i,j) = G%mask2dBu(I+i0,J+j0) * US%L_T_to_m_s * & 0.5*(sfc_state%v(i+i0,J+j0)+sfc_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)*sfc_state%u(I+i0,j+j0) - Ocean_sfc%v_surf(i,j) = G%mask2dCv(i+i0,J+j0)*sfc_state%v(i+i0,J+j0) + Ocean_sfc%u_surf(i,j) = G%mask2dCu(I+i0,j+j0)*US%L_T_to_m_s * sfc_state%u(I+i0,j+j0) + Ocean_sfc%v_surf(i,j) = G%mask2dCv(i+i0,J+j0)*US%L_T_to_m_s * sfc_state%v(i+i0,J+j0) enddo ; enddo else write(val_str, '(I8)') Ocean_sfc%stagger diff --git a/config_src/mct_driver/mom_ocean_model_mct.F90 b/config_src/mct_driver/mom_ocean_model_mct.F90 index 317a496399..0ef8a7a9d4 100644 --- a/config_src/mct_driver/mom_ocean_model_mct.F90 +++ b/config_src/mct_driver/mom_ocean_model_mct.F90 @@ -924,22 +924,22 @@ subroutine convert_state_to_ocean_type(sfc_state, Ocean_sfc, G, US, patm, press_ 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) * & + Ocean_sfc%u_surf(i,j) = G%mask2dT(i+i0,j+j0) * US%L_T_to_m_s * & 0.5*(sfc_state%u(I+i0,j+j0)+sfc_state%u(I-1+i0,j+j0)) - Ocean_sfc%v_surf(i,j) = G%mask2dT(i+i0,j+j0) * & + Ocean_sfc%v_surf(i,j) = G%mask2dT(i+i0,j+j0) * US%L_T_to_m_s * & 0.5*(sfc_state%v(i+i0,J+j0)+sfc_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) * & + Ocean_sfc%u_surf(i,j) = G%mask2dBu(I+i0,J+j0) * US%L_T_to_m_s * & 0.5*(sfc_state%u(I+i0,j+j0)+sfc_state%u(I+i0,j+j0+1)) - Ocean_sfc%v_surf(i,j) = G%mask2dBu(I+i0,J+j0) * & + Ocean_sfc%v_surf(i,j) = G%mask2dBu(I+i0,J+j0) * US%L_T_to_m_s * & 0.5*(sfc_state%v(i+i0,J+j0)+sfc_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)*sfc_state%u(I+i0,j+j0) - Ocean_sfc%v_surf(i,j) = G%mask2dCv(i+i0,J+j0)*sfc_state%v(i+i0,J+j0) + Ocean_sfc%u_surf(i,j) = G%mask2dCu(I+i0,j+j0) * US%L_T_to_m_s * sfc_state%u(I+i0,j+j0) + Ocean_sfc%v_surf(i,j) = G%mask2dCv(i+i0,J+j0) * US%L_T_to_m_s * sfc_state%v(i+i0,J+j0) enddo ; enddo else write(val_str, '(I8)') Ocean_sfc%stagger diff --git a/config_src/nuopc_driver/mom_ocean_model_nuopc.F90 b/config_src/nuopc_driver/mom_ocean_model_nuopc.F90 index ffbe73881a..1a08869b77 100644 --- a/config_src/nuopc_driver/mom_ocean_model_nuopc.F90 +++ b/config_src/nuopc_driver/mom_ocean_model_nuopc.F90 @@ -919,22 +919,22 @@ subroutine convert_state_to_ocean_type(sfc_state, Ocean_sfc, G, US, patm, press_ 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) * & + Ocean_sfc%u_surf(i,j) = G%mask2dT(i+i0,j+j0) * US%L_T_to_m_s * & 0.5*(sfc_state%u(I+i0,j+j0)+sfc_state%u(I-1+i0,j+j0)) - Ocean_sfc%v_surf(i,j) = G%mask2dT(i+i0,j+j0) * & + Ocean_sfc%v_surf(i,j) = G%mask2dT(i+i0,j+j0) * US%L_T_to_m_s * & 0.5*(sfc_state%v(i+i0,J+j0)+sfc_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) * & + Ocean_sfc%u_surf(i,j) = G%mask2dBu(I+i0,J+j0) * US%L_T_to_m_s * & 0.5*(sfc_state%u(I+i0,j+j0)+sfc_state%u(I+i0,j+j0+1)) - Ocean_sfc%v_surf(i,j) = G%mask2dBu(I+i0,J+j0) * & + Ocean_sfc%v_surf(i,j) = G%mask2dBu(I+i0,J+j0) * US%L_T_to_m_s * & 0.5*(sfc_state%v(i+i0,J+j0)+sfc_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)*sfc_state%u(I+i0,j+j0) - Ocean_sfc%v_surf(i,j) = G%mask2dCv(i+i0,J+j0)*sfc_state%v(i+i0,J+j0) + Ocean_sfc%u_surf(i,j) = G%mask2dCu(I+i0,j+j0) * US%L_T_to_m_s * sfc_state%u(I+i0,j+j0) + Ocean_sfc%v_surf(i,j) = G%mask2dCv(i+i0,J+j0) * US%L_T_to_m_s * sfc_state%v(i+i0,J+j0) enddo ; enddo else write(val_str, '(I8)') Ocean_sfc%stagger diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index 49eed5fe1f..c47115ed68 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -3029,10 +3029,10 @@ subroutine extract_surface_state(CS, sfc_state_in) sfc_state%SSS(i,j) = CS%tv%S(i,j,1) enddo ; enddo ; endif do j=js,je ; do I=is-1,ie - sfc_state%u(I,j) = US%L_T_to_m_s * CS%u(I,j,1) + sfc_state%u(I,j) = CS%u(I,j,1) enddo ; enddo do J=js-1,je ; do i=is,ie - sfc_state%v(i,J) = US%L_T_to_m_s * CS%v(i,J,1) + sfc_state%v(i,J) = CS%v(i,J,1) enddo ; enddo else ! (CS%Hmix >= 0.0) @@ -3125,7 +3125,7 @@ subroutine extract_surface_state(CS, sfc_state_in) else dh = 0.0 endif - sfc_state%v(i,J) = sfc_state%v(i,J) + dh * US%L_T_to_m_s * CS%v(i,J,k) + sfc_state%v(i,J) = sfc_state%v(i,J) + dh * CS%v(i,J,k) depth(i) = depth(i) + dh enddo ; enddo ! Calculate the average properties of the mixed layer depth. @@ -3149,7 +3149,7 @@ subroutine extract_surface_state(CS, sfc_state_in) else dh = 0.0 endif - sfc_state%u(I,j) = sfc_state%u(I,j) + dh * US%L_T_to_m_s * CS%u(I,j,k) + sfc_state%u(I,j) = sfc_state%u(I,j) + dh * CS%u(I,j,k) depth(I) = depth(I) + dh enddo ; enddo ! Calculate the average properties of the mixed layer depth. @@ -3159,10 +3159,10 @@ subroutine extract_surface_state(CS, sfc_state_in) enddo ! end of j loop else ! Hmix_UV<=0. do j=js,je ; do I=is-1,ie - sfc_state%u(I,j) = US%L_T_to_m_s * CS%u(I,j,1) + sfc_state%u(I,j) = CS%u(I,j,1) enddo ; enddo do J=js-1,je ; do i=is,ie - sfc_state%v(i,J) = US%L_T_to_m_s * CS%v(i,J,1) + sfc_state%v(i,J) = CS%v(i,J,1) enddo ; enddo endif endif ! (CS%Hmix >= 0.0) @@ -3311,16 +3311,16 @@ subroutine extract_surface_state(CS, sfc_state_in) 'x=',G%gridLonT(ig), 'y=',G%gridLatT(jg), & 'D=',bathy_m, 'SSH=',sfc_state%sea_lev(i,j), & 'SST=',sfc_state%SST(i,j), 'SSS=',sfc_state%SSS(i,j), & - 'U-=',sfc_state%u(I-1,j), 'U+=',sfc_state%u(I,j), & - 'V-=',sfc_state%v(i,J-1), 'V+=',sfc_state%v(i,J) + 'U-=',US%L_T_to_m_s*sfc_state%u(I-1,j), 'U+=',US%L_T_to_m_s*sfc_state%u(I,j), & + 'V-=',US%L_T_to_m_s*sfc_state%v(i,J-1), 'V+=',US%L_T_to_m_s*sfc_state%v(i,J) else write(msg(1:240),'(2(a,i4,x),4(a,f8.3,x),6(a,es11.4))') & 'Extreme surface sfc_state detected: i=',ig,'j=',jg, & 'lon=',G%geoLonT(i,j), 'lat=',G%geoLatT(i,j), & 'x=',G%gridLonT(i), 'y=',G%gridLatT(j), & 'D=',bathy_m, 'SSH=',sfc_state%sea_lev(i,j), & - 'U-=',sfc_state%u(I-1,j), 'U+=',sfc_state%u(I,j), & - 'V-=',sfc_state%v(i,J-1), 'V+=',sfc_state%v(i,J) + 'U-=',US%L_T_to_m_s*sfc_state%u(I-1,j), 'U+=',US%L_T_to_m_s*sfc_state%u(I,j), & + 'V-=',US%L_T_to_m_s*sfc_state%v(i,J-1), 'V+=',US%L_T_to_m_s*sfc_state%v(i,J) endif call MOM_error(WARNING, trim(msg), all_print=.true.) elseif (numberOfErrors==9) then ! Indicate once that there are more errors diff --git a/src/core/MOM_checksum_packages.F90 b/src/core/MOM_checksum_packages.F90 index dfe34676a6..c63b15a3b4 100644 --- a/src/core/MOM_checksum_packages.F90 +++ b/src/core/MOM_checksum_packages.F90 @@ -162,7 +162,8 @@ subroutine MOM_surface_chksum(mesg, sfc_state, G, haloshift, symmetric) if (allocated(sfc_state%sea_lev)) call hchksum(sfc_state%sea_lev, mesg//" sea_lev", G%HI, haloshift=hs) if (allocated(sfc_state%Hml)) call hchksum(sfc_state%Hml, mesg//" Hml", G%HI, haloshift=hs) if (allocated(sfc_state%u) .and. allocated(sfc_state%v)) & - call uvchksum(mesg//" SSU", sfc_state%u, sfc_state%v, G%HI, haloshift=hs, symmetric=sym) + call uvchksum(mesg//" SSU", sfc_state%u, sfc_state%v, G%HI, haloshift=hs, symmetric=sym, & + scale=G%US%L_T_to_m_s) ! if (allocated(sfc_state%salt_deficit)) & ! call hchksum(sfc_state%salt_deficit, mesg//" salt deficit", G%HI, haloshift=hs) if (allocated(sfc_state%frazil)) call hchksum(sfc_state%frazil, mesg//" frazil", G%HI, haloshift=hs) diff --git a/src/core/MOM_variables.F90 b/src/core/MOM_variables.F90 index 2ac62eee5a..2b7cafdd33 100644 --- a/src/core/MOM_variables.F90 +++ b/src/core/MOM_variables.F90 @@ -44,8 +44,8 @@ module MOM_variables SSS, & !< The sea surface salinity [ppt ~> psu or gSalt/kg]. sfc_density, & !< The mixed layer density [kg m-3]. Hml, & !< The mixed layer depth [m]. - u, & !< The mixed layer zonal velocity [m s-1]. - v, & !< The mixed layer meridional velocity [m s-1]. + u, & !< The mixed layer zonal velocity [L T-1 ~> m s-1]. + v, & !< The mixed layer meridional velocity [L T-1 ~> m s-1]. sea_lev, & !< The sea level [m]. If a reduced surface gravity is !! used, that is compensated for in sea_lev. frazil, & !< The energy needed to heat the ocean column to the freezing point during diff --git a/src/diagnostics/MOM_diagnostics.F90 b/src/diagnostics/MOM_diagnostics.F90 index 77739f3ead..c5c47b743f 100644 --- a/src/diagnostics/MOM_diagnostics.F90 +++ b/src/diagnostics/MOM_diagnostics.F90 @@ -1169,7 +1169,7 @@ subroutine post_surface_dyn_diags(IDs, G, diag, sfc_state, ssh) intent(in) :: ssh !< Time mean surface height without corrections for ice displacement [m] ! Local variables - real, dimension(SZI_(G),SZJ_(G)) :: work_2d ! A 2-d work array + real, dimension(SZI_(G),SZJ_(G)) :: speed ! The surface speed [L T-1 ~> m s-1] integer :: i, j, is, ie, js, je is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec @@ -1185,10 +1185,10 @@ subroutine post_surface_dyn_diags(IDs, G, diag, sfc_state, ssh) 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)) + speed(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) + call post_data(IDs%id_speed, speed, diag, mask=G%mask2dT) endif end subroutine post_surface_dyn_diags @@ -1784,11 +1784,11 @@ subroutine register_surface_diags(Time, G, US, IDs, diag, tv) long_name='Area averaged sea surface height', units='m', & standard_name='area_averaged_sea_surface_height') IDs%id_ssu = register_diag_field('ocean_model', 'SSU', diag%axesCu1, Time, & - 'Sea Surface Zonal Velocity', 'm s-1') + 'Sea Surface Zonal Velocity', 'm s-1', conversion=US%L_T_to_m_s) IDs%id_ssv = register_diag_field('ocean_model', 'SSV', diag%axesCv1, Time, & - 'Sea Surface Meridional Velocity', 'm s-1') + 'Sea Surface Meridional Velocity', 'm s-1', conversion=US%L_T_to_m_s) IDs%id_speed = register_diag_field('ocean_model', 'speed', diag%axesT1, Time, & - 'Sea Surface Speed', 'm s-1') + 'Sea Surface Speed', 'm s-1', conversion=US%L_T_to_m_s) if (associated(tv%T)) then IDs%id_sst = register_diag_field('ocean_model', 'SST', diag%axesT1, Time, & diff --git a/src/ice_shelf/MOM_ice_shelf.F90 b/src/ice_shelf/MOM_ice_shelf.F90 index 819ce8bb76..3e8b1ed83b 100644 --- a/src/ice_shelf/MOM_ice_shelf.F90 +++ b/src/ice_shelf/MOM_ice_shelf.F90 @@ -334,8 +334,8 @@ subroutine shelf_calc_flux(sfc_state, fluxes, Time, time_step, CS, forces) call hchksum(fluxes%frac_shelf_h, "frac_shelf_h before apply melting", G%HI, haloshift=0) call hchksum(sfc_state%sst, "sst before apply melting", G%HI, haloshift=0) call hchksum(sfc_state%sss, "sss before apply melting", G%HI, haloshift=0) - call hchksum(sfc_state%u, "u_ml before apply melting", G%HI, haloshift=0) - call hchksum(sfc_state%v, "v_ml before apply melting", G%HI, haloshift=0) + call hchksum(sfc_state%u, "u_ml before apply melting", G%HI, haloshift=0, scale=US%L_T_to_m_s) + call hchksum(sfc_state%v, "v_ml before apply melting", G%HI, haloshift=0, scale=US%L_T_to_m_s) call hchksum(sfc_state%ocean_mass, "ocean_mass before apply melting", G%HI, haloshift=0) endif @@ -356,8 +356,8 @@ subroutine shelf_calc_flux(sfc_state, fluxes, Time, time_step, CS, forces) taux2 = (asu1 * sfc_state%taux_shelf(I-1,j)**2 + asu2 * sfc_state%taux_shelf(I,j)**2 ) * I_au tauy2 = (asv1 * sfc_state%tauy_shelf(i,J-1)**2 + asv2 * sfc_state%tauy_shelf(i,J)**2 ) * I_av endif - u2_av = US%m_s_to_L_T**2*(asu1 * sfc_state%u(I-1,j)**2 + asu2 * sfc_state%u(I,j)**2) * I_au - v2_av = US%m_s_to_L_T**2*(asv1 * sfc_state%v(i,J-1)**2 + asu2 * sfc_state%v(i,J)**2) * I_av + u2_av = (asu1 * sfc_state%u(I-1,j)**2 + asu2 * sfc_state%u(I,j)**2) * I_au + v2_av = (asv1 * sfc_state%v(i,J-1)**2 + asu2 * sfc_state%v(i,J)**2) * I_av if (taux2 + tauy2 > 0.0) then fluxes%ustar_shelf(i,j) = MAX(CS%ustar_bg, US%L_to_Z * & @@ -1617,9 +1617,9 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl CS%id_Sbdry = register_diag_field('ocean_model', 'sbdry', CS%diag%axesT1, CS%Time, & 'salinity at the ice-ocean interface.', 'psu') CS%id_u_ml = register_diag_field('ocean_model', 'u_ml', CS%diag%axesCu1, CS%Time, & - 'Eastward vel. in the boundary layer (used to compute ustar)', 'm s-1') + 'Eastward vel. in the boundary layer (used to compute ustar)', 'm s-1', conversion=US%L_T_to_m_s) CS%id_v_ml = register_diag_field('ocean_model', 'v_ml', CS%diag%axesCv1, CS%Time, & - 'Northward vel. in the boundary layer (used to compute ustar)', 'm s-1') + 'Northward vel. in the boundary layer (used to compute ustar)', 'm s-1', conversion=US%L_T_to_m_s) CS%id_exch_vel_s = register_diag_field('ocean_model', 'exch_vel_s', CS%diag%axesT1, CS%Time, & 'Sub-shelf salinity exchange velocity', 'm s-1', conversion=US%Z_to_m*US%s_to_T) CS%id_exch_vel_t = register_diag_field('ocean_model', 'exch_vel_t', CS%diag%axesT1, CS%Time, & diff --git a/src/user/Idealized_Hurricane.F90 b/src/user/Idealized_Hurricane.F90 index 5727309926..a8ec1d06ff 100644 --- a/src/user/Idealized_Hurricane.F90 +++ b/src/user/Idealized_Hurricane.F90 @@ -263,13 +263,13 @@ subroutine idealized_hurricane_wind_forcing(sfc_state, forces, day, G, US, CS) !> Computes taux do j=js,je do I=is-1,Ieq - Uocn = US%m_s_to_L_T * sfc_state%u(I,j)*REL_TAU_FAC + Uocn = sfc_state%u(I,j) * REL_TAU_FAC if (CS%answers_2018) then - Vocn = US%m_s_to_L_T * 0.25*(sfc_state%v(i,J)+sfc_state%v(i+1,J-1)& - +sfc_state%v(i+1,J)+sfc_state%v(i,J-1))*REL_TAU_FAC + Vocn = 0.25*(sfc_state%v(i,J)+sfc_state%v(i+1,J-1)& + +sfc_state%v(i+1,J)+sfc_state%v(i,J-1))*REL_TAU_FAC else - Vocn = US%m_s_to_L_T * 0.25*((sfc_state%v(i,J)+sfc_state%v(i+1,J-1)) +& - (sfc_state%v(i+1,J)+sfc_state%v(i,J-1))) * REL_TAU_FAC + Vocn =0.25*((sfc_state%v(i,J)+sfc_state%v(i+1,J-1)) +& + (sfc_state%v(i+1,J)+sfc_state%v(i,J-1))) * REL_TAU_FAC endif f_local = abs(0.5*(G%CoriolisBu(I,J)+G%CoriolisBu(I,J-1)))*fbench_fac + fbench ! Calculate position as a function of time. @@ -288,13 +288,13 @@ subroutine idealized_hurricane_wind_forcing(sfc_state, forces, day, G, US, CS) do J=js-1,Jeq do i=is,ie if (CS%answers_2018) then - Uocn = US%m_s_to_L_T * 0.25*(sfc_state%u(I,j)+sfc_state%u(I-1,j+1) + & - sfc_state%u(I-1,j)+sfc_state%u(I,j+1))*REL_TAU_FAC + Uocn = 0.25*(sfc_state%u(I,j)+sfc_state%u(I-1,j+1) + & + sfc_state%u(I-1,j)+sfc_state%u(I,j+1))*REL_TAU_FAC else - Uocn = US%m_s_to_L_T * 0.25*((sfc_state%u(I,j)+sfc_state%u(I-1,j+1)) + & - (sfc_state%u(I-1,j)+sfc_state%u(I,j+1))) * REL_TAU_FAC + Uocn = 0.25*((sfc_state%u(I,j)+sfc_state%u(I-1,j+1)) + & + (sfc_state%u(I-1,j)+sfc_state%u(I,j+1))) * REL_TAU_FAC endif - Vocn = US%m_s_to_L_T * sfc_state%v(i,J)*REL_TAU_FAC + Vocn = sfc_state%v(i,J) * REL_TAU_FAC f_local = abs(0.5*(G%CoriolisBu(I-1,J)+G%CoriolisBu(I,J)))*fbench_fac + fbench ! Calculate position as a function of time. if (CS%SCM_mode) then From 4b8fffcb73316204295005f7d00d4864ec9d4d0b Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 30 Apr 2020 11:46:03 -0400 Subject: [PATCH 245/316] +Rescaled sfc_state%sfc_density and sfc_state%Hml Dimensionally rescaled the surface density and mixed layer depth variables in the surface type to [R] and [Z], respectively. All answers are bitwise identical, but the units of two elements in a transparent type have changed. --- config_src/ice_solo_driver/MOM_surface_forcing.F90 | 8 ++++---- config_src/ice_solo_driver/user_surface_forcing.F90 | 9 ++++----- config_src/mct_driver/mom_ocean_model_mct.F90 | 2 +- config_src/nuopc_driver/mom_ocean_model_nuopc.F90 | 2 +- config_src/solo_driver/MESO_surface_forcing.F90 | 9 ++++----- config_src/solo_driver/MOM_surface_forcing.F90 | 8 ++++---- config_src/solo_driver/Neverland_surface_forcing.F90 | 8 ++++---- config_src/solo_driver/user_surface_forcing.F90 | 2 +- src/core/MOM.F90 | 6 +++--- src/core/MOM_checksum_packages.F90 | 3 ++- src/core/MOM_variables.F90 | 4 ++-- src/ice_shelf/MOM_ice_shelf.F90 | 2 +- src/user/BFB_surface_forcing.F90 | 2 +- 13 files changed, 32 insertions(+), 33 deletions(-) diff --git a/config_src/ice_solo_driver/MOM_surface_forcing.F90 b/config_src/ice_solo_driver/MOM_surface_forcing.F90 index 1e59fee863..8e218fb6c4 100644 --- a/config_src/ice_solo_driver/MOM_surface_forcing.F90 +++ b/config_src/ice_solo_driver/MOM_surface_forcing.F90 @@ -112,7 +112,7 @@ module MOM_surface_forcing real, pointer :: T_Restore(:,:) => NULL() !< temperature to damp (restore) the SST to [degC] real, pointer :: S_Restore(:,:) => NULL() !< salinity to damp (restore) the SSS [ppt] - real, pointer :: Dens_Restore(:,:) => NULL() !< density to damp (restore) surface density [kg m-3] + real, pointer :: Dens_Restore(:,:) => NULL() !< density to damp (restore) surface density [R ~> kg m-3] integer :: wind_last_lev_read = -1 !< The last time level read from the wind input files integer :: buoy_last_lev_read = -1 !< The last time level read from buoyancy input files @@ -774,7 +774,7 @@ subroutine buoyancy_forcing_from_files(sfc_state, fluxes, day, dt, G, US, CS) do j=js,je ; do i=is,ie if (G%mask2dT(i,j) > 0) then fluxes%buoy(i,j) = (CS%Dens_Restore(i,j) - sfc_state%sfc_density(i,j)) * & - (CS%G_Earth * CS%Flux_const/(US%R_to_kg_m3*CS%Rho0)) + (CS%G_Earth * CS%Flux_const / CS%Rho0) else fluxes%buoy(i,j) = 0.0 endif @@ -909,8 +909,8 @@ subroutine buoyancy_forcing_linear(sfc_state, fluxes, day, dt, G, US, CS) "RESTOREBUOY to linear not written yet.") !do j=js,je ; do i=is,ie ! if (G%mask2dT(i,j) > 0) then - ! fluxes%buoy(i,j) = US%kg_m3_to_R*(CS%Dens_Restore(i,j) - sfc_state%sfc_density(i,j)) * & - ! (CS%G_Earth * CS%Flux_const / CS%Rho0) + ! fluxes%buoy(i,j) = (CS%Dens_Restore(i,j) - sfc_state%sfc_density(i,j)) * & + ! (CS%G_Earth * CS%Flux_const / CS%Rho0) ! else ! fluxes%buoy(i,j) = 0.0 ! endif diff --git a/config_src/ice_solo_driver/user_surface_forcing.F90 b/config_src/ice_solo_driver/user_surface_forcing.F90 index 10417d4a1e..1b372bf44b 100644 --- a/config_src/ice_solo_driver/user_surface_forcing.F90 +++ b/config_src/ice_solo_driver/user_surface_forcing.F90 @@ -177,8 +177,7 @@ subroutine USER_buoyancy_forcing(sfc_state, fluxes, day, dt, G, US, CS) real :: Temp_restore ! The temperature that is being restored toward [C]. real :: Salin_restore ! The salinity that is being restored toward [ppt] - real :: density_restore ! The potential density that is being restored - ! toward [kg m-3]. + real :: density_restore ! The potential density that is being restored toward [R ~> kg m-3]. real :: rhoXcp ! The mean density times the heat capacity [Q R degC-1 ~> J m-3 degC-1]. real :: buoy_rest_const ! A constant relating density anomalies to the ! restoring buoyancy flux [L2 T-3 R-1 ~> m5 s-3 kg-1]. @@ -271,11 +270,11 @@ subroutine USER_buoyancy_forcing(sfc_state, fluxes, day, dt, G, US, CS) buoy_rest_const = -1.0 * (CS%G_Earth * CS%Flux_const) / CS%Rho0 do j=js,je ; do i=is,ie ! Set density_restore to an expression for the surface potential - ! density [kg m-3] that is being restored toward. - density_restore = 1030.0 + ! density [R ~> kg m-3] that is being restored toward. + density_restore = 1030.0*US%kg_m3_to_R fluxes%buoy(i,j) = G%mask2dT(i,j) * buoy_rest_const * & - US%kg_m3_to_R*(density_restore - sfc_state%sfc_density(i,j)) + (density_restore - sfc_state%sfc_density(i,j)) enddo ; enddo endif endif ! end RESTOREBUOY diff --git a/config_src/mct_driver/mom_ocean_model_mct.F90 b/config_src/mct_driver/mom_ocean_model_mct.F90 index 0ef8a7a9d4..1d1e9fa888 100644 --- a/config_src/mct_driver/mom_ocean_model_mct.F90 +++ b/config_src/mct_driver/mom_ocean_model_mct.F90 @@ -918,7 +918,7 @@ subroutine convert_state_to_ocean_type(sfc_state, Ocean_sfc, G, US, patm, press_ if (allocated(sfc_state%Hml)) then do j=jsc_bnd,jec_bnd ; do i=isc_bnd,iec_bnd - Ocean_sfc%OBLD(i,j) = sfc_state%Hml(i+i0,j+j0) + Ocean_sfc%OBLD(i,j) = US%Z_to_m*sfc_state%Hml(i+i0,j+j0) enddo ; enddo endif diff --git a/config_src/nuopc_driver/mom_ocean_model_nuopc.F90 b/config_src/nuopc_driver/mom_ocean_model_nuopc.F90 index 1a08869b77..22a4c7eaa2 100644 --- a/config_src/nuopc_driver/mom_ocean_model_nuopc.F90 +++ b/config_src/nuopc_driver/mom_ocean_model_nuopc.F90 @@ -913,7 +913,7 @@ subroutine convert_state_to_ocean_type(sfc_state, Ocean_sfc, G, US, patm, press_ if (allocated(sfc_state%Hml)) then do j=jsc_bnd,jec_bnd ; do i=isc_bnd,iec_bnd - Ocean_sfc%OBLD(i,j) = sfc_state%Hml(i+i0,j+j0) + Ocean_sfc%OBLD(i,j) = US%Z_to_m*sfc_state%Hml(i+i0,j+j0) enddo ; enddo endif diff --git a/config_src/solo_driver/MESO_surface_forcing.F90 b/config_src/solo_driver/MESO_surface_forcing.F90 index ebe98a3293..cc0939ac17 100644 --- a/config_src/solo_driver/MESO_surface_forcing.F90 +++ b/config_src/solo_driver/MESO_surface_forcing.F90 @@ -79,8 +79,7 @@ subroutine MESO_buoyancy_forcing(sfc_state, fluxes, day, dt, G, US, CS) real :: Temp_restore ! The temperature that is being restored toward [degC]. real :: Salin_restore ! The salinity that is being restored toward [ppt] - real :: density_restore ! The potential density that is being restored - ! toward [kg m-3]. + real :: density_restore ! The potential density that is being restored toward [R ~> kg m-3]. real :: rhoXcp ! The mean density times the heat capacity [Q R degC-1 ~> J m-3 degC-1]. real :: buoy_rest_const ! A constant relating density anomalies to the ! restoring buoyancy flux [L2 T-3 R-1 ~> m5 s-3 kg-1]. @@ -194,11 +193,11 @@ subroutine MESO_buoyancy_forcing(sfc_state, fluxes, day, dt, G, US, CS) buoy_rest_const = -1.0 * (CS%G_Earth * CS%Flux_const) / CS%Rho0 do j=js,je ; do i=is,ie ! Set density_restore to an expression for the surface potential - ! density [kg m-3] that is being restored toward. - density_restore = 1030.0 + ! density [R ~> kg m-3] that is being restored toward. + density_restore = 1030.0 * US%kg_m3_to_R fluxes%buoy(i,j) = G%mask2dT(i,j) * buoy_rest_const * & - US%kg_m3_to_R * (density_restore - sfc_state%sfc_density(i,j)) + (density_restore - sfc_state%sfc_density(i,j)) enddo ; enddo endif endif ! end RESTOREBUOY diff --git a/config_src/solo_driver/MOM_surface_forcing.F90 b/config_src/solo_driver/MOM_surface_forcing.F90 index df403712f7..173d417ff3 100644 --- a/config_src/solo_driver/MOM_surface_forcing.F90 +++ b/config_src/solo_driver/MOM_surface_forcing.F90 @@ -95,7 +95,7 @@ module MOM_surface_forcing real, pointer :: T_Restore(:,:) => NULL() !< temperature to damp (restore) the SST to [degC] real, pointer :: S_Restore(:,:) => NULL() !< salinity to damp (restore) the SSS [ppt] - real, pointer :: Dens_Restore(:,:) => NULL() !< density to damp (restore) surface density [kg m-3] + real, pointer :: Dens_Restore(:,:) => NULL() !< density to damp (restore) surface density [R ~> kg m-3] integer :: buoy_last_lev_read = -1 !< The last time level read from buoyancy input files @@ -1000,7 +1000,7 @@ subroutine buoyancy_forcing_from_files(sfc_state, fluxes, day, dt, G, US, CS) else do j=js,je ; do i=is,ie if (G%mask2dT(i,j) > 0) then - fluxes%buoy(i,j) = US%kg_m3_to_R * (CS%Dens_Restore(i,j) - sfc_state%sfc_density(i,j)) * & + fluxes%buoy(i,j) = (CS%Dens_Restore(i,j) - sfc_state%sfc_density(i,j)) * & (CS%G_Earth * CS%Flux_const / CS%Rho0) else fluxes%buoy(i,j) = 0.0 @@ -1161,7 +1161,7 @@ subroutine buoyancy_forcing_from_data_override(sfc_state, fluxes, day, dt, G, US else do j=js,je ; do i=is,ie if (G%mask2dT(i,j) > 0) then - fluxes%buoy(i,j) = US%kg_m3_to_R * (CS%Dens_Restore(i,j) - sfc_state%sfc_density(i,j)) * & + fluxes%buoy(i,j) = (CS%Dens_Restore(i,j) - sfc_state%sfc_density(i,j)) * & (CS%G_Earth * CS%Flux_const / CS%Rho0) else fluxes%buoy(i,j) = 0.0 @@ -1362,7 +1362,7 @@ subroutine buoyancy_forcing_linear(sfc_state, fluxes, day, dt, G, US, CS) "RESTOREBUOY to linear not written yet.") !do j=js,je ; do i=is,ie ! if (G%mask2dT(i,j) > 0) then - ! fluxes%buoy(i,j) = US%kg_m3_to_R * (CS%Dens_Restore(i,j) - sfc_state%sfc_density(i,j)) * & + ! fluxes%buoy(i,j) = (CS%Dens_Restore(i,j) - sfc_state%sfc_density(i,j)) * & ! (CS%G_Earth * CS%Flux_const / CS%Rho0) ! else ! fluxes%buoy(i,j) = 0.0 diff --git a/config_src/solo_driver/Neverland_surface_forcing.F90 b/config_src/solo_driver/Neverland_surface_forcing.F90 index e6b7152e86..a53eaec27e 100644 --- a/config_src/solo_driver/Neverland_surface_forcing.F90 +++ b/config_src/solo_driver/Neverland_surface_forcing.F90 @@ -148,7 +148,7 @@ subroutine Neverland_buoyancy_forcing(sfc_state, fluxes, day, dt, G, US, CS) ! Local variables real :: buoy_rest_const ! A constant relating density anomalies to the ! restoring buoyancy flux [L2 T-3 R-1 ~> m5 s-3 kg-1]. - real :: density_restore ! De + real :: density_restore ! Density being restored toward [R ~> kg m-3] integer :: i, j, is, ie, js, je integer :: isd, ied, jsd, jed @@ -199,11 +199,11 @@ subroutine Neverland_buoyancy_forcing(sfc_state, fluxes, day, dt, G, US, CS) buoy_rest_const = -1.0 * (CS%G_Earth * CS%Flux_const) / CS%Rho0 do j=js,je ; do i=is,ie ! Set density_restore to an expression for the surface potential - ! density [kg m-3] that is being restored toward. - density_restore = 1030.0 + ! density [R ~> kg m-3] that is being restored toward. + density_restore = 1030.0*US%kg_m3_to_R fluxes%buoy(i,j) = G%mask2dT(i,j) * buoy_rest_const * & - US%kg_m3_to_R*(density_restore - sfc_state%sfc_density(i,j)) + (density_restore - sfc_state%sfc_density(i,j)) enddo ; enddo endif endif ! end RESTOREBUOY diff --git a/config_src/solo_driver/user_surface_forcing.F90 b/config_src/solo_driver/user_surface_forcing.F90 index 97da89e69e..a95046fe20 100644 --- a/config_src/solo_driver/user_surface_forcing.F90 +++ b/config_src/solo_driver/user_surface_forcing.F90 @@ -226,7 +226,7 @@ subroutine USER_buoyancy_forcing(sfc_state, fluxes, day, dt, G, US, CS) density_restore = 1030.0*US%kg_m3_to_R fluxes%buoy(i,j) = G%mask2dT(i,j) * buoy_rest_const * & - (density_restore - US%kg_m3_to_R*sfc_state%sfc_density(i,j)) + (density_restore - sfc_state%sfc_density(i,j)) enddo ; enddo endif endif ! end RESTOREBUOY diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index c47115ed68..77b8bdd7d8 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -3019,7 +3019,7 @@ subroutine extract_surface_state(CS, sfc_state_in) ! copy Hml into sfc_state, so that caps can access it if (associated(CS%Hml)) then do j=js,je ; do i=is,ie - sfc_state%Hml(i,j) = CS%Hml(i,j) + sfc_state%Hml(i,j) = US%m_to_Z*CS%Hml(i,j) enddo ; enddo endif @@ -3064,7 +3064,7 @@ subroutine extract_surface_state(CS, sfc_state_in) sfc_state%SST(i,j) = sfc_state%SST(i,j) + dh * CS%tv%T(i,j,k) sfc_state%SSS(i,j) = sfc_state%SSS(i,j) + dh * CS%tv%S(i,j,k) else - sfc_state%sfc_density(i,j) = sfc_state%sfc_density(i,j) + dh * US%R_to_kg_m3*GV%Rlay(k) + sfc_state%sfc_density(i,j) = sfc_state%sfc_density(i,j) + dh * GV%Rlay(k) endif depth(i) = depth(i) + dh enddo ; enddo @@ -3088,7 +3088,7 @@ subroutine extract_surface_state(CS, sfc_state_in) sfc_state%SSS(i,j) = (sfc_state%SSS(i,j) + missing_depth*CS%tv%S(i,j,1)) * I_depth else sfc_state%sfc_density(i,j) = (sfc_state%sfc_density(i,j) + & - missing_depth*US%R_to_kg_m3*GV%Rlay(1)) * I_depth + missing_depth*GV%Rlay(1)) * I_depth endif else I_depth = 1.0 / depth(i) diff --git a/src/core/MOM_checksum_packages.F90 b/src/core/MOM_checksum_packages.F90 index c63b15a3b4..47369cf474 100644 --- a/src/core/MOM_checksum_packages.F90 +++ b/src/core/MOM_checksum_packages.F90 @@ -160,7 +160,8 @@ subroutine MOM_surface_chksum(mesg, sfc_state, G, haloshift, symmetric) if (allocated(sfc_state%SST)) call hchksum(sfc_state%SST, mesg//" SST", G%HI, haloshift=hs) if (allocated(sfc_state%SSS)) call hchksum(sfc_state%SSS, mesg//" SSS", G%HI, haloshift=hs) if (allocated(sfc_state%sea_lev)) call hchksum(sfc_state%sea_lev, mesg//" sea_lev", G%HI, haloshift=hs) - if (allocated(sfc_state%Hml)) call hchksum(sfc_state%Hml, mesg//" Hml", G%HI, haloshift=hs) + if (allocated(sfc_state%Hml)) call hchksum(sfc_state%Hml, mesg//" Hml", G%HI, haloshift=hs, & + scale=G%US%Z_to_m) if (allocated(sfc_state%u) .and. allocated(sfc_state%v)) & call uvchksum(mesg//" SSU", sfc_state%u, sfc_state%v, G%HI, haloshift=hs, symmetric=sym, & scale=G%US%L_T_to_m_s) diff --git a/src/core/MOM_variables.F90 b/src/core/MOM_variables.F90 index 2b7cafdd33..b74e90ff5e 100644 --- a/src/core/MOM_variables.F90 +++ b/src/core/MOM_variables.F90 @@ -42,8 +42,8 @@ module MOM_variables real, allocatable, dimension(:,:) :: & SST, & !< The sea surface temperature [degC]. SSS, & !< The sea surface salinity [ppt ~> psu or gSalt/kg]. - sfc_density, & !< The mixed layer density [kg m-3]. - Hml, & !< The mixed layer depth [m]. + sfc_density, & !< The mixed layer density [R ~> kg m-3]. + Hml, & !< The mixed layer depth [Z ~> m]. u, & !< The mixed layer zonal velocity [L T-1 ~> m s-1]. v, & !< The mixed layer meridional velocity [L T-1 ~> m s-1]. sea_lev, & !< The sea level [m]. If a reduced surface gravity is diff --git a/src/ice_shelf/MOM_ice_shelf.F90 b/src/ice_shelf/MOM_ice_shelf.F90 index 3e8b1ed83b..d104dfe82a 100644 --- a/src/ice_shelf/MOM_ice_shelf.F90 +++ b/src/ice_shelf/MOM_ice_shelf.F90 @@ -397,7 +397,7 @@ subroutine shelf_calc_flux(sfc_state, fluxes, Time, time_step, CS, forces) ! reported ocean mixed layer thickness and the neutral Ekman depth. absf = 0.25*((abs(G%CoriolisBu(I,J)) + abs(G%CoriolisBu(I-1,J-1))) + & (abs(G%CoriolisBu(I,J-1)) + abs(G%CoriolisBu(I-1,J)))) - if (absf*US%m_to_Z*sfc_state%Hml(i,j) <= VK*ustar_h) then ; hBL_neut = US%m_to_Z*sfc_state%Hml(i,j) + if (absf*sfc_state%Hml(i,j) <= VK*ustar_h) then ; hBL_neut = sfc_state%Hml(i,j) else ; hBL_neut = (VK*ustar_h) / absf ; endif hBL_neut_h_molec = ZETA_N * ((hBL_neut * ustar_h) / (5.0 * CS%kv_molec)) diff --git a/src/user/BFB_surface_forcing.F90 b/src/user/BFB_surface_forcing.F90 index a6aae3d3f7..88e7ae45d5 100644 --- a/src/user/BFB_surface_forcing.F90 +++ b/src/user/BFB_surface_forcing.F90 @@ -164,7 +164,7 @@ subroutine BFB_buoyancy_forcing(sfc_state, fluxes, day, dt, G, US, CS) density_restore = Temp_restore*CS%drho_dt + CS%Rho0 fluxes%buoy(i,j) = G%mask2dT(i,j) * buoy_rest_const * & - (density_restore - US%kg_m3_to_R*sfc_state%sfc_density(i,j)) + (density_restore - sfc_state%sfc_density(i,j)) enddo ; enddo endif endif ! end RESTOREBUOY From 897e0d3cb06d5447a2c04faae288974cd6616219 Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Thu, 30 Apr 2020 20:44:44 +0000 Subject: [PATCH 246/316] Removes module MOM_PressureForce_blk_AFV.F90 - The blocked form of the analytic PGF has been removed. We'll re-apply this concept after unifying the forms of PGF. Deleting this option simplifies the clean up exercise. - Removes the needs for two hor_index_type arguments in several routines. - Parameter BLOCKED_ANALYTIC_FV_PGF has been obsoleted. --- src/core/MOM_PressureForce.F90 | 30 +- src/core/MOM_PressureForce_analytic_FV.F90 | 6 +- src/core/MOM_PressureForce_blocked_AFV.F90 | 867 --------------------- src/diagnostics/MOM_diagnostics.F90 | 2 +- src/diagnostics/MOM_obsolete_params.F90 | 2 + src/equation_of_state/MOM_EOS.F90 | 291 ++++--- src/equation_of_state/MOM_EOS_Wright.F90 | 50 +- src/equation_of_state/MOM_EOS_linear.F90 | 52 +- 8 files changed, 195 insertions(+), 1105 deletions(-) delete mode 100644 src/core/MOM_PressureForce_blocked_AFV.F90 diff --git a/src/core/MOM_PressureForce.F90 b/src/core/MOM_PressureForce.F90 index 6fad3e0d93..6902e13341 100644 --- a/src/core/MOM_PressureForce.F90 +++ b/src/core/MOM_PressureForce.F90 @@ -10,9 +10,6 @@ module MOM_PressureForce use MOM_PressureForce_AFV, only : PressureForce_AFV_Bouss, PressureForce_AFV_nonBouss 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_end use MOM_PressureForce_Mont, only : PressureForce_Mont_CS @@ -35,8 +32,6 @@ module MOM_PressureForce !! 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 @@ -67,15 +62,7 @@ subroutine PressureForce(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm, pbce, e optional, intent(out) :: eta !< The bottom mass used to calculate PFu and PFv, !! [H ~> m or kg m-2], 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, US, & - CS%PressureForce_blk_AFV_CSp, ALE_CSp, p_atm, pbce, eta) - else - call PressureForce_blk_AFV_nonBouss(h, tv, PFu, PFv, G, GV, US, & - CS%PressureForce_blk_AFV_CSp, p_atm, pbce, eta) - endif - elseif (CS%Analytic_FV_PGF) then + if (CS%Analytic_FV_PGF) then if (GV%Boussinesq) then call PressureForce_AFV_Bouss(h, tv, PFu, PFv, G, GV, US, CS%PressureForce_AFV_CSp, & ALE_CSp, p_atm, pbce, eta) @@ -122,15 +109,8 @@ subroutine PressureForce_init(Time, G, GV, US, param_file, diag, CS, tides_CSp) "the equations of state in pressure to avoid any "//& "possibility of numerical thermobaric instability, as "//& "described in Adcroft et al., O. Mod. (2008).", default=.true.) - call get_param(param_file, mdl, "BLOCKED_ANALYTIC_FV_PGF", CS%blocked_AFV, & - "If true, used the blocked version of the ANALYTIC_FV_PGF "//& - "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, US, param_file, diag, & - CS%PressureForce_blk_AFV_CSp, tides_CSp) - elseif (CS%Analytic_FV_PGF) then + + if (CS%Analytic_FV_PGF) then call PressureForce_AFV_init(Time, G, GV, US, param_file, diag, & CS%PressureForce_AFV_CSp, tides_CSp) else @@ -144,9 +124,7 @@ end subroutine PressureForce_init 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 + if (CS%Analytic_FV_PGF) then call PressureForce_AFV_end(CS%PressureForce_AFV_CSp) else call PressureForce_Mont_end(CS%PressureForce_Mont_CSp) diff --git a/src/core/MOM_PressureForce_analytic_FV.F90 b/src/core/MOM_PressureForce_analytic_FV.F90 index 614bf3bc8a..cfb4535351 100644 --- a/src/core/MOM_PressureForce_analytic_FV.F90 +++ b/src/core/MOM_PressureForce_analytic_FV.F90 @@ -671,17 +671,17 @@ subroutine PressureForce_AFV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_at 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, & + 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, & + rho_ref, CS%Rho0, GV%g_Earth, G%HI, tv%eqn_of_state, dpa, & intz_dpa, intx_dpa, inty_dpa) 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%HI, tv%eqn_of_state, dpa, & + rho_ref, CS%Rho0, GV%g_Earth, G%HI, tv%eqn_of_state, dpa, & intz_dpa, intx_dpa, inty_dpa, G%bathyT, dz_neglect, CS%useMassWghtInterp) endif !$OMP parallel do default(shared) diff --git a/src/core/MOM_PressureForce_blocked_AFV.F90 b/src/core/MOM_PressureForce_blocked_AFV.F90 deleted file mode 100644 index ab0c665f7a..0000000000 --- a/src/core/MOM_PressureForce_blocked_AFV.F90 +++ /dev/null @@ -1,867 +0,0 @@ -!> 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_unit_scaling, only : unit_scale_type -use MOM_variables, only : thermo_var_ptrs -use MOM_verticalGrid, only : verticalGrid_type -use MOM_EOS, only : calculate_density, 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 - -! A note on unit descriptions in comments: MOM6 uses units that can be rescaled for dimensional -! consistency testing. These are noted in comments with units like Z, H, L, and T, along with -! their mks counterparts with notation like "a velocity [Z T-1 ~> m s-1]". If the units -! vary with the Boussinesq approximation, the Boussinesq variant is given first. - -!> 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 [R ~> kg m-3]. - real :: GFS_scale !< A scaling of the surface pressure gradients to - !! allow the use of a reduced gravity model [nondim]. - 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, US, 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 - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer thickness [H ~> m or kg m-2] - type(thermo_var_ptrs), intent(inout) :: tv !< Thermodynamic variables - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(out) :: PFu !< Zonal acceleration [L T-2 ~> m s-2] - real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(out) :: PFv !< Meridional acceleration [L T-2 ~> m s-2] - 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 [R L2 T-2 ~> Pa]. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), optional, intent(out) :: pbce !< The baroclinic pressure - !! anomaly in each layer due to eta anomalies - !! [L2 T-2 H-1 ~> m s-2 or m4 s-2 kg-1]. - real, dimension(SZI_(G),SZJ_(G)), optional, intent(out) :: eta !< The bottom mass used to - !! calculate PFu and PFv [H ~> m or kg m-2], with any tidal - !! contributions or compressibility compensation. - - if (GV%Boussinesq) then - call PressureForce_blk_AFV_bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm, pbce, eta) - else - call PressureForce_blk_AFV_nonbouss(h, tv, PFu, PFv, G, GV, US, 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 (is:ie,js:je) -!! range before this subroutine is called: -!! h(isB:ie+1,jsB:je+1), T(isB:ie+1,jsB:je+1), and S(isB:ie+1,jsB:je+1). -subroutine PressureForce_blk_AFV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, pbce, eta) - type(ocean_grid_type), intent(in) :: G !< Ocean grid structure - type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer thickness [H ~> kg m-2] - type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamic variables - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(out) :: PFu !< Zonal acceleration [L T-2 ~> m s-2] - real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(out) :: PFv !< Meridional acceleration [L T-2 ~> m s-2] - 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 [R L2 T-2 ~> Pa]. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), optional, intent(out) :: pbce !< The baroclinic pressure - !! anomaly in each layer due to eta anomalies - !! [L2 T-2 H-1 ~> m s-2 or m4 s-2 kg-1]. - real, dimension(SZI_(G),SZJ_(G)), optional, intent(out) :: eta !< The bottom mass used to - !! calculate PFu and PFv [H ~> m or kg m-2], with any tidal - !! contributions or compressibility compensation. - ! Local variables - real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1) :: p ! Interface pressure [R L2 T-2 ~> 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 [degC]. - S_tmp ! Temporary array of salinities where layers that are lighter - ! than the mixed layer have the mixed layer's properties [ppt]. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: & - dza, & ! The change in geopotential anomaly between the top and bottom - ! of a layer [L2 T-2 ~> m2 s-2]. - intp_dza ! The vertical integral in depth of the pressure anomaly less - ! the pressure anomaly at the top of the layer [R L4 T-4 ~> Pa m2 s-2]. - real, dimension(SZI_(G),SZJ_(G)) :: & - dp, & ! The (positive) change in pressure across a layer [R L2 T-2 ~> Pa]. - SSH, & ! The sea surface height anomaly, in depth units [Z ~> m]. - e_tidal, & ! The bottom geopotential anomaly due to tidal forces from - ! astronomical sources and self-attraction and loading [Z ~> m]. - dM, & ! The barotropic adjustment to the Montgomery potential to - ! account for a reduced gravity model [L2 T-2 ~> m2 s-2]. - za ! The geopotential anomaly (i.e. g*e + alpha_0*pressure) at the - ! interface atop a layer [L2 T-2 ~> 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 [R L2 T-2 ~> Pa]. - za_bk ! The geopotential anomaly (i.e. g*e + alpha_0*pressure) at the - ! interface atop a layer [L2 T-2 ~> m2 s-2]. - - real, dimension(SZI_(G)) :: Rho_cv_BL ! The coordinate potential density in the deepest variable - ! density near-surface layer [R ~> 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 [L2 T-2 ~> m2 s-2]. - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)) :: & - intx_dza ! The change in intx_za through a layer [L2 T-2 ~> 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 [L2 T-2 ~> m2 s-2]. - real, dimension(SZI_(G),SZJB_(G),SZK_(G)) :: & - inty_dza ! The change in inty_za through a layer [L2 T-2 ~> m2 s-2]. - real :: p_ref(SZI_(G)) ! The pressure used to calculate the coordinate - ! density [R L2 T-2 ~> 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 [R L2 T-2 ~> Pa]. - real :: I_gEarth ! The inverse of GV%g_Earth [L2 Z L-2 ~> s2 m-1] - real :: alpha_anom ! The in-situ specific volume, averaged over a - ! layer, less alpha_ref [R-1 ~> 3 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 [R-1 ~> m3 kg-1] that is used - ! to reduce the impact of truncation errors. - real :: rho_in_situ(SZI_(G)) ! The in situ density [R ~> kg m-3]. - real :: Pa_to_H ! A factor to convert from Pa to the thicknesss units (H) [H T2 R-1 L-2 ~> H Pa-1]. - real :: H_to_RL2_T2 ! A factor to convert from thicknesss units (H) to pressure units [R L2 T-2 H-1 ~> Pa H-1]. -! real :: oneatm = 101325.0 ! 1 atm in [Pa] = [kg m-1 s-2] - real, parameter :: C1_6 = 1.0/6.0 - integer, dimension(2) :: EOSdom ! The computational domain for the equation of state - 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 - EOSdom(1) = Isq - (G%isd-1) ; EOSdom(2) = G%iec+1 - (G%isd-1) - - 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) - - H_to_RL2_T2 = GV%g_Earth*GV%H_to_RZ - dp_neglect = GV%g_Earth*GV%H_to_RZ * GV%H_subroundoff - alpha_ref = 1.0 / CS%Rho0 - I_gEarth = 1.0 / GV%g_Earth - - 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) + H_to_RL2_T2 * h(i,j,k-1) - 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(:), & - tv%eqn_of_state, EOSdom) - 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) = H_to_RL2_T2 * 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, m_to_Z=US%m_to_Z) - !$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, & - tv%eqn_of_state, EOSdom) - - 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,PFv,CS,dM,US, & -!$OMP intp_dza,p,dp_neglect,inty_dza,H_to_RL2_T2) & -!$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) = H_to_RL2_T2*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, US, CS%GFS_scale, pbce) - endif - - if (present(eta)) then - Pa_to_H = 1.0 / (GV%g_Earth * GV%H_to_RZ) - 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 (is:ie,js:je) -!! range before this subroutine is called: -!! h(isB:ie+1,jsB:je+1), T(isB:ie+1,jsB:je+1), and S(isB:ie+1,jsB:je+1). -subroutine PressureForce_blk_AFV_Bouss(h, tv, PFu, PFv, G, GV, US, 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 - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer thickness [H ~> m or kg m-2] - type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamic variables - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(out) :: PFu !< Zonal acceleration [L T-2 ~> m s-2] - real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(out) :: PFv !< Meridional acceleration [L T-2 ~> m s-2] - 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 [R L2 T-2 ~> Pa]. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), optional, intent(out) :: pbce !< The baroclinic pressure - !! anomaly in each layer due to eta anomalies - !! [L2 T-2 H-1 ~> m s-2 or m4 s-2 kg-1]. - real, dimension(SZI_(G),SZJ_(G)), optional, intent(out) :: eta !< The bottom mass used to - !! calculate PFu and PFv [H ~> m or kg m-2], with any tidal - !! contributions or compressibility compensation. - ! Local variables - real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1) :: e ! Interface height in depth units [Z ~> 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 depth units [Z ~> m]. - dM ! The barotropic adjustment to the Montgomery potential to - ! account for a reduced gravity model [L2 T-2 ~> m2 s-2]. - real, dimension(SZI_(G)) :: & - Rho_cv_BL ! The coordinate potential density in the deepest variable - ! density near-surface layer [R ~> 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 [L2 T-2 ~> m2 s-2]. - pa_bk, & ! The pressure anomaly (i.e. pressure + g*RHO_0*e) at the - ! the interface atop a layer [R L2 T-2 ~> Pa]. - dpa_bk, & ! The change in pressure anomaly between the top and bottom - ! of a layer [R L2 T-2 ~> Pa]. - intz_dpa_bk ! The vertical integral in depth of the pressure anomaly less the - ! pressure anomaly at the top of the layer [H R L2 T-2 ~> m Pa or kg m-2 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 [R L2 T-2 ~> Pa]. - intx_dpa_bk ! The change in intx_pa through a layer [R L2 T-2 ~> 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 [R L2 T-2 ~> Pa]. - inty_dpa_bk ! The change in inty_pa through a layer [R L2 T-2 ~> 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 [degC]. - S_tmp ! Temporary array of salinities where layers that are lighter - ! than the mixed layer have the mixed layer's properties [ppt]. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: & - S_t, S_b, & ! Top and bottom edge salinities for linear reconstructions within each layer [ppt]. - T_t, T_b ! Top and bottom edge temperatures for linear reconstructions within each layer [degC]. - real :: rho_in_situ(SZI_(G)) ! The in situ density [R ~> kg m-3]. - real :: p_ref(SZI_(G)) ! The pressure used to calculate the coordinate - ! density [R L2 T-2 ~> Pa] (usually 2e7 Pa = 2000 dbar). - real :: p0(SZI_(G)) ! An array of zeros to use for pressure [R L2 T-2 ~> Pa]. - real :: h_neglect ! A thickness that is so small it is usually lost - ! in roundoff and can be neglected [H ~> m or kg m-2]. - real :: I_Rho0 ! The inverse of the Boussinesq reference density [R-1 ~> m3 kg-1]. - real :: G_Rho0 ! G_Earth / Rho0 [L2 Z-1 T-2 R-1 ~> m4 s-2 kg-1]. - real :: rho_ref ! The reference density [R ~> kg m-3]. - real :: dz_neglect ! A minimal thickness [Z ~> 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, dimension(2) :: EOSdom ! The computational domain for the equation of state - 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 - EOSdom(1) = Isq - (G%isd-1) ; EOSdom(2) = G%iec+1 - (G%isd-1) - - 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_Z - 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) = -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_Z - enddo ; enddo - enddo - call calc_tidal_forcing(CS%Time, e(:,:,1), e_tidal, G, CS%tides_CSp, m_to_Z=US%m_to_Z) - 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) = -(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) = -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_Z - 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(:), & - tv%eqn_of_state, EOSdom) - - 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, & - tv%eqn_of_state, EOSdom) - else - call calculate_density(tv_tmp%T(:,j,1), tv_tmp%S(:,j,1), p0, rho_in_situ, & - tv%eqn_of_state, EOSdom) - 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,US,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%Z_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_Z*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%Z_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%Z_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, US, 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%Z_to_H + e_tidal(i,j)*GV%Z_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%Z_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, US, 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(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - 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 "//& - "calculate accelerations and the mass for conservation "//& - "properties, or with BOUSSINSEQ false to convert some "//& - "parameters from vertical units of m to kg m-2.", & - units="kg m-3", default=1035.0, scale=US%kg_m3_to_R) - 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). "//& - "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 "//& - "integrals near the bathymetry in AFV pressure gradient "//& - "calculations.", default=.false.) - call get_param(param_file, mdl, "RECONSTRUCT_FOR_PRESSURE", CS%reconstruct, & - "If True, use vertical reconstruction of T & S within "//& - "the integrals of the FV pressure gradient calculation. "//& - "If False, use the constant-by-layer algorithm. "//& - "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 "//& - "integrals within the FV pressure gradient calculation.\n"//& - " 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 "//& - "boundary cells is extrapolated, rather than using PCM "//& - "in these cells. If true, the same order polynomial is "//& - "used as is used for the interior cells.", default=.true.) - - 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', conversion=US%Z_to_m) - 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 !< Blocked AFV pressure control structure that - !! will be deallocated in this subroutine. - 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/diagnostics/MOM_diagnostics.F90 b/src/diagnostics/MOM_diagnostics.F90 index 77739f3ead..38d486aba8 100644 --- a/src/diagnostics/MOM_diagnostics.F90 +++ b/src/diagnostics/MOM_diagnostics.F90 @@ -846,7 +846,7 @@ subroutine calculate_vertical_integrals(h, tv, p_surf, G, GV, US, CS) z_bot(i,j) = z_top(i,j) - GV%H_to_Z*h(i,j,k) enddo ; enddo call int_density_dz(tv%T(:,:,k), tv%S(:,:,k), z_top, z_bot, 0.0, GV%Rho0, GV%g_Earth, & - G%HI, G%HI, tv%eqn_of_state, dpress) + G%HI, tv%eqn_of_state, dpress) do j=js,je ; do i=is,ie mass(i,j) = mass(i,j) + dpress(i,j) * IG_Earth enddo ; enddo diff --git a/src/diagnostics/MOM_obsolete_params.F90 b/src/diagnostics/MOM_obsolete_params.F90 index 1f674290d3..e669328748 100644 --- a/src/diagnostics/MOM_obsolete_params.F90 +++ b/src/diagnostics/MOM_obsolete_params.F90 @@ -34,6 +34,8 @@ subroutine find_obsolete_params(param_file) call obsolete_logical(param_file, "JACOBIAN_PGF", .false., & hint="Instead use ANALYTIC_FV_PGF.") + call obsolete_logical(param_file, "BLOCKED_ANALYTIC_FV_PGF", & + hint="BLOCKED_ANALYTIC_FV_PGF is no longer available.") call obsolete_logical(param_file, "SADOURNY", & hint="Instead use CORIOLIS_SCHEME='SADOURNY'.") diff --git a/src/equation_of_state/MOM_EOS.F90 b/src/equation_of_state/MOM_EOS.F90 index 49820d7ff8..c584b68c89 100644 --- a/src/equation_of_state/MOM_EOS.F90 +++ b/src/equation_of_state/MOM_EOS.F90 @@ -1062,17 +1062,16 @@ 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. -subroutine int_density_dz(T, S, z_t, z_b, rho_ref, rho_0, G_e, HII, HIO, EOS, dpa, & +subroutine int_density_dz(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, EOS, dpa, & intz_dpa, intx_dpa, inty_dpa, bathyT, dz_neglect, useMassWghtInterp) - type(hor_index_type), intent(in) :: HII !< Ocean horizontal index structures for the input arrays - type(hor_index_type), intent(in) :: HIO !< Ocean horizontal index structures for the output arrays - real, dimension(HII%isd:HII%ied,HII%jsd:HII%jed), & + type(hor_index_type), intent(in) :: HI !< Ocean horizontal index structure + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & intent(in) :: T !< Potential temperature referenced to the surface [degC] - real, dimension(HII%isd:HII%ied,HII%jsd:HII%jed), & + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & intent(in) :: S !< Salinity [ppt] - real, dimension(HII%isd:HII%ied,HII%jsd:HII%jed), & + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & intent(in) :: z_t !< Height at the top of the layer in depth units [Z ~> m] - real, dimension(HII%isd:HII%ied,HII%jsd:HII%jed), & + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & intent(in) :: z_b !< Height at the bottom of the layer [Z ~> m] real, intent(in) :: rho_ref !< A mean density [R ~> kg m-3] or [kg m-3], that is !! subtracted out to reduce the magnitude of each of the @@ -1083,22 +1082,22 @@ subroutine int_density_dz(T, S, z_t, z_b, rho_ref, rho_0, G_e, HII, HIO, EOS, dp real, intent(in) :: G_e !< The Earth's gravitational acceleration !! [L2 Z-1 T-2 ~> m s-2] or [m2 Z-1 s-2 ~> m s-2] type(EOS_type), pointer :: EOS !< Equation of state structure - real, dimension(HIO%isd:HIO%ied,HIO%jsd:HIO%jed), & + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & intent(inout) :: dpa !< The change in the pressure anomaly !! across the layer [R L2 T-2 ~> Pa] or [Pa] - real, dimension(HIO%isd:HIO%ied,HIO%jsd:HIO%jed), & + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & optional, intent(inout) :: intz_dpa !< The integral through the thickness of the !! layer of the pressure anomaly relative to the !! anomaly at the top of the layer [R L2 Z T-2 ~> Pa m] - real, dimension(HIO%IsdB:HIO%IedB,HIO%jsd:HIO%jed), & + real, dimension(HI%IsdB:HI%IedB,HI%jsd:HI%jed), & optional, intent(inout) :: 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 [R L2 T-2 ~> Pa] - real, dimension(HIO%isd:HIO%ied,HIO%JsdB:HIO%JedB), & + real, dimension(HI%isd:HI%ied,HI%JsdB:HI%JedB), & optional, intent(inout) :: 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 [R L2 T-2 ~> Pa] - real, dimension(HII%isd:HII%ied,HII%jsd:HII%jed), & + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & optional, intent(in) :: bathyT !< The depth of the bathymetry [Z ~> m] real, optional, intent(in) :: dz_neglect !< A miniscule thickness change [Z ~> m] logical, optional, intent(in) :: useMassWghtInterp !< If true, uses mass weighting to @@ -1112,17 +1111,17 @@ subroutine int_density_dz(T, S, z_t, z_b, rho_ref, rho_0, G_e, HII, HIO, EOS, dp "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, & + call int_density_dz_generic(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, EOS, dpa, & intz_dpa, intx_dpa, inty_dpa, bathyT, dz_neglect, useMassWghtInterp) else ; select case (EOS%form_of_EOS) case (EOS_LINEAR) rho_scale = EOS%kg_m3_to_R if (rho_scale /= 1.0) then - call int_density_dz_linear(T, S, z_t, z_b, rho_ref, rho_0, G_e, HII, HIO, & + call int_density_dz_linear(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & rho_scale*EOS%Rho_T0_S0, rho_scale*EOS%dRho_dT, rho_scale*EOS%dRho_dS, & dpa, intz_dpa, intx_dpa, inty_dpa, bathyT, dz_neglect, useMassWghtInterp) else - call int_density_dz_linear(T, S, z_t, z_b, rho_ref, rho_0, G_e, HII, HIO, & + call int_density_dz_linear(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & EOS%Rho_T0_S0, EOS%dRho_dT, EOS%dRho_dS, & dpa, intz_dpa, intx_dpa, inty_dpa, bathyT, dz_neglect, useMassWghtInterp) endif @@ -1130,16 +1129,16 @@ subroutine int_density_dz(T, S, z_t, z_b, rho_ref, rho_0, G_e, HII, HIO, EOS, dp rho_scale = EOS%kg_m3_to_R pres_scale = EOS%RL2_T2_to_Pa if ((rho_scale /= 1.0) .or. (pres_scale /= 1.0)) then - call int_density_dz_wright(T, S, z_t, z_b, rho_ref, rho_0, G_e, HII, HIO, & + call int_density_dz_wright(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & dpa, intz_dpa, intx_dpa, inty_dpa, bathyT, & dz_neglect, useMassWghtInterp, rho_scale, pres_scale) else - call int_density_dz_wright(T, S, z_t, z_b, rho_ref, rho_0, G_e, HII, HIO, & + call int_density_dz_wright(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & dpa, intz_dpa, intx_dpa, inty_dpa, bathyT, & dz_neglect, useMassWghtInterp) endif case default - call int_density_dz_generic(T, S, z_t, z_b, rho_ref, rho_0, G_e, HII, HIO, EOS, dpa, & + call int_density_dz_generic(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, EOS, dpa, & intz_dpa, intx_dpa, inty_dpa, bathyT, dz_neglect, useMassWghtInterp) end select ; endif @@ -1340,18 +1339,17 @@ 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, & +subroutine int_density_dz_generic(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & 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), & + type(hor_index_type), intent(in) :: HI !< Horizontal index type for variables. + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & intent(in) :: T !< Potential temperature of the layer [degC] - real, dimension(HII%isd:HII%ied,HII%jsd:HII%jed), & + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & intent(in) :: S !< Salinity of the layer [ppt] - real, dimension(HII%isd:HII%ied,HII%jsd:HII%jed), & + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & intent(in) :: z_t !< Height at the top of the layer in depth units [Z ~> m] - real, dimension(HII%isd:HII%ied,HII%jsd:HII%jed), & + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & intent(in) :: z_b !< Height at the bottom of the layer [Z ~> m] real, intent(in) :: rho_ref !< A mean density [R ~> kg m-3] or [kg m-3], that is !! subtracted out to reduce the magnitude @@ -1362,22 +1360,22 @@ subroutine int_density_dz_generic(T, S, z_t, z_b, rho_ref, rho_0, G_e, HII, HIO, real, intent(in) :: G_e !< The Earth's gravitational acceleration !! [L2 Z-1 T-2 ~> m s-2] or [m2 Z-1 s-2 ~> m s-2] type(EOS_type), pointer :: EOS !< Equation of state structure - real, dimension(HIO%isd:HIO%ied,HIO%jsd:HIO%jed), & + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & intent(inout) :: dpa !< The change in the pressure anomaly !! across the layer [R L2 T-2 ~> Pa] or [Pa] - real, dimension(HIO%isd:HIO%ied,HIO%jsd:HIO%jed), & + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & optional, intent(inout) :: intz_dpa !< The integral through the thickness of the !! layer of the pressure anomaly relative to the !! anomaly at the top of the layer [R L2 Z T-2 ~> Pa m] - real, dimension(HIO%IsdB:HIO%IedB,HIO%jsd:HIO%jed), & + real, dimension(HI%IsdB:HI%IedB,HI%jsd:HI%jed), & optional, intent(inout) :: 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 [R L2 T-2 ~> Pa] - real, dimension(HIO%isd:HIO%ied,HIO%JsdB:HIO%JedB), & + real, dimension(HI%isd:HI%ied,HI%JsdB:HI%JedB), & optional, intent(inout) :: 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 [R L2 T-2 ~> Pa] - real, dimension(HII%isd:HII%ied,HII%jsd:HII%jed), & + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & optional, intent(in) :: bathyT !< The depth of the bathymetry [Z ~> m] real, optional, intent(in) :: dz_neglect !< A miniscule thickness change [Z ~> m] logical, optional, intent(in) :: useMassWghtInterp !< If true, uses mass weighting to @@ -1404,17 +1402,14 @@ subroutine int_density_dz_generic(T, S, z_t, z_b, rho_ref, rho_0, G_e, HII, HIO, real :: intz(5) ! The gravitational acceleration times the integrals of density ! with height at the 5 sub-column locations [R L2 T-2 ~> Pa] or [Pa] 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 - joff = HIO%jdg_offset - HII%jdg_offset + integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, i, j, m, n ! These array bounds work for the indexing convention of the input arrays, but ! on the computational domain defined for the output arrays. - Isq = HIO%IscB + ioff ; Ieq = HIO%IecB + ioff - Jsq = HIO%JscB + joff ; Jeq = HIO%JecB + joff - is = HIO%isc + ioff ; ie = HIO%iec + ioff - js = HIO%jsc + joff ; je = HIO%jec + joff + Isq = HI%IscB ; Ieq = HI%IecB + Jsq = HI%JscB ; Jeq = HI%JecB + is = HI%isc ; ie = HI%iec + js = HI%jsc ; je = HI%jec rho_scale = EOS%kg_m3_to_R GxRho = EOS%RL2_T2_to_Pa * G_e * rho_0 @@ -1444,10 +1439,10 @@ subroutine int_density_dz_generic(T, S, z_t, z_b, rho_ref, rho_0, G_e, HII, HIO, ! 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)) - dpa(i-ioff,j-joff) = G_e*dz*rho_anom + 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. - if (present(intz_dpa)) intz_dpa(i-ioff,j-joff) = 0.5*G_e*dz**2 * & + 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))) ) enddo ; enddo @@ -1469,7 +1464,7 @@ subroutine int_density_dz_generic(T, S, z_t, z_b, rho_ref, rho_0, G_e, HII, HIO, 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) + intz(1) = dpa(i,j) ; intz(5) = dpa(i+1,j) do m=2,4 ! T, S, and z are interpolated in the horizontal. The z interpolation ! is linear, but for T and S it may be thickness weighted. @@ -1492,7 +1487,7 @@ subroutine int_density_dz_generic(T, S, z_t, z_b, rho_ref, rho_0, G_e, HII, HIO, 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)) + & + intx_dpa(i,j) = C1_90*(7.0*(intz(1)+intz(5)) + 32.0*(intz(2)+intz(4)) + & 12.0*intz(3)) enddo ; enddo ; endif @@ -1514,7 +1509,7 @@ subroutine int_density_dz_generic(T, S, z_t, z_b, rho_ref, rho_0, G_e, HII, HIO, 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) + intz(1) = dpa(i,j) ; intz(5) = dpa(i,j+1) do m=2,4 ! T, S, and z are interpolated in the horizontal. The z interpolation ! is linear, but for T and S it may be thickness weighted. @@ -1538,7 +1533,7 @@ subroutine int_density_dz_generic(T, S, z_t, z_b, rho_ref, rho_0, G_e, HII, HIO, 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)) + & + inty_dpa(i,j) = C1_90*(7.0*(intz(1)+intz(5)) + 32.0*(intz(2)+intz(4)) + & 12.0*intz(3)) enddo ; enddo ; endif end subroutine int_density_dz_generic @@ -1548,21 +1543,20 @@ end subroutine int_density_dz_generic !> Compute pressure gradient force integrals by quadrature for the case where !! T and S are linear profiles. subroutine int_density_dz_generic_plm (T_t, T_b, S_t, S_b, z_t, z_b, rho_ref, & - rho_0, G_e, dz_subroundoff, bathyT, HII, HIO, EOS, dpa, & + rho_0, G_e, dz_subroundoff, bathyT, HI, EOS, dpa, & intz_dpa, intx_dpa, inty_dpa, useMassWghtInterp) - type(hor_index_type), intent(in) :: HII !< Ocean horizontal index structures for the input arrays - type(hor_index_type), intent(in) :: HIO !< Ocean horizontal index structures for the output arrays - real, dimension(HII%isd:HII%ied,HII%jsd:HII%jed), & + type(hor_index_type), intent(in) :: HI !< Ocean horizontal index structures for the arrays + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & intent(in) :: T_t !< Potential temperatue at the cell top [degC] - real, dimension(HII%isd:HII%ied,HII%jsd:HII%jed), & + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & intent(in) :: T_b !< Potential temperatue at the cell bottom [degC] - real, dimension(HII%isd:HII%ied,HII%jsd:HII%jed), & + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & intent(in) :: S_t !< Salinity at the cell top [ppt] - real, dimension(HII%isd:HII%ied,HII%jsd:HII%jed), & + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & intent(in) :: S_b !< Salinity at the cell bottom [ppt] - real, dimension(HII%isd:HII%ied,HII%jsd:HII%jed), & + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & intent(in) :: z_t !< The geometric height at the top of the layer [Z ~> m] - real, dimension(HII%isd:HII%ied,HII%jsd:HII%jed), & + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & intent(in) :: z_b !< The geometric height at the bottom of the layer [Z ~> m] real, intent(in) :: rho_ref !< A mean density [R ~> kg m-3] or [kg m-3], that is subtracted !! out to reduce the magnitude of each of the integrals. @@ -1570,20 +1564,20 @@ subroutine int_density_dz_generic_plm (T_t, T_b, S_t, S_b, z_t, z_b, rho_ref, & !! 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 [L2 Z-1 T-2 ~> m s-2] real, intent(in) :: dz_subroundoff !< A miniscule thickness change [Z ~> m] - real, dimension(HII%isd:HII%ied,HII%jsd:HII%jed), & + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & intent(in) :: bathyT !< The depth of the bathymetry [Z ~> m] type(EOS_type), pointer :: EOS !< Equation of state structure - real, dimension(HIO%isd:HIO%ied,HIO%jsd:HIO%jed), & + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & intent(inout) :: dpa !< The change in the pressure anomaly across the layer [R L2 T-2 ~> Pa] - real, dimension(HIO%isd:HIO%ied,HIO%jsd:HIO%jed), & + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & optional, intent(inout) :: intz_dpa !< The integral through the thickness of the layer of !! the pressure anomaly relative to the anomaly at the !! top of the layer [R L2 Z T-2 ~> Pa Z] - real, dimension(HIO%IsdB:HIO%IedB,HIO%jsd:HIO%jed), & + real, dimension(HI%IsdB:HI%IedB,HI%jsd:HI%jed), & optional, intent(inout) :: 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 [R L2 T-2 ~> Pa] - real, dimension(HIO%isd:HIO%ied,HIO%JsdB:HIO%JedB), & + real, dimension(HI%isd:HI%ied,HI%JsdB:HI%JedB), & optional, intent(inout) :: 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 [R L2 T-2 ~> Pa] @@ -1602,17 +1596,17 @@ subroutine int_density_dz_generic_plm (T_t, T_b, S_t, S_b, z_t, z_b, rho_ref, & ! a linear interpolation is used to compute intermediate values. ! Local variables - real :: T5((5*HIO%iscB+1):(5*(HIO%iecB+2))) ! Temperatures along a line of subgrid locations [degC] - real :: S5((5*HIO%iscB+1):(5*(HIO%iecB+2))) ! Salinities along a line of subgrid locations [ppt] - real :: p5((5*HIO%iscB+1):(5*(HIO%iecB+2))) ! Pressures along a line of subgrid locations, never - ! rescaled from Pa [Pa] - real :: r5((5*HIO%iscB+1):(5*(HIO%iecB+2))) ! Densities anomalies along a line of subgrid - ! locations [R ~> kg m-3] or [kg m-3] - real :: T15((15*HIO%iscB+1):(15*(HIO%iecB+1))) ! Temperatures at an array of subgrid locations [degC] - real :: S15((15*HIO%iscB+1):(15*(HIO%iecB+1))) ! Salinities at an array of subgrid locations [ppt] - real :: p15((15*HIO%iscB+1):(15*(HIO%iecB+1))) ! Pressures at an array of subgrid locations [Pa] - real :: r15((15*HIO%iscB+1):(15*(HIO%iecB+1))) ! Densities at an array of subgrid locations - ! [R ~> kg m-3] or [kg m-3] + real :: T5((5*HI%iscB+1):(5*(HI%iecB+2))) ! Temperatures along a line of subgrid locations [degC] + real :: S5((5*HI%iscB+1):(5*(HI%iecB+2))) ! Salinities along a line of subgrid locations [ppt] + real :: p5((5*HI%iscB+1):(5*(HI%iecB+2))) ! Pressures along a line of subgrid locations, never + ! rescaled from Pa [Pa] + real :: r5((5*HI%iscB+1):(5*(HI%iecB+2))) ! Densities anomalies along a line of subgrid + ! locations [R ~> kg m-3] or [kg m-3] + real :: T15((15*HI%iscB+1):(15*(HI%iecB+1))) ! Temperatures at an array of subgrid locations [degC] + real :: S15((15*HI%iscB+1):(15*(HI%iecB+1))) ! Salinities at an array of subgrid locations [ppt] + real :: p15((15*HI%iscB+1):(15*(HI%iecB+1))) ! Pressures at an array of subgrid locations [Pa] + real :: r15((15*HI%iscB+1):(15*(HI%iecB+1))) ! Densities at an array of subgrid locations + ! [R ~> kg m-3] or [kg m-3] real :: wt_t(5), wt_b(5) ! Top and bottom weights [nondim] real :: rho_anom ! A density anomaly [R ~> kg m-3] or [kg m-3] real :: w_left, w_right ! Left and right weights [nondim] @@ -1623,9 +1617,9 @@ subroutine int_density_dz_generic_plm (T_t, T_b, S_t, S_b, z_t, z_b, rho_ref, & real :: I_Rho ! The inverse of the Boussinesq density [R-1 ~> m3 kg-1] or [m3 kg-1] real :: rho_scale ! A scaling factor for densities from kg m-3 to R [R m3 kg-1 ~> 1] real :: rho_ref_mks ! The reference density in MKS units, never rescaled from kg m-3 [kg m-3] - real :: dz(HIO%iscB:HIO%iecB+1) ! Layer thicknesses at tracer points [Z ~> m] - real :: dz_x(5,HIO%iscB:HIO%iecB) ! Layer thicknesses along an x-line of subrid locations [Z ~> m] - real :: dz_y(5,HIO%isc:HIO%iec) ! Layer thicknesses along a y-line of subrid locations [Z ~> m] + real :: dz(HI%iscB:HI%iecB+1) ! Layer thicknesses at tracer points [Z ~> m] + real :: dz_x(5,HI%iscB:HI%iecB) ! Layer thicknesses along an x-line of subrid locations [Z ~> m] + real :: dz_y(5,HI%isc:HI%iec) ! Layer thicknesses along a y-line of subrid locations [Z ~> m] real :: weight_t, weight_b ! Nondimensional weights of the top and bottom [nondim] real :: massWeightToggle ! A nondimensional toggle factor (0 or 1) [nondim] real :: Ttl, Tbl, Ttr, Tbr ! Temperatures at the velocity cell corners [degC] @@ -1634,13 +1628,9 @@ subroutine int_density_dz_generic_plm (T_t, T_b, S_t, S_b, z_t, z_b, rho_ref, & real :: hL, hR ! Thicknesses to the left and right [Z ~> m] real :: iDenom ! The denominator of the thickness weight expressions [Z-2 ~> m-2] integer :: Isq, Ieq, Jsq, Jeq, i, j, m, n - integer :: iin, jin, ioff, joff integer :: pos - ioff = HIO%idg_offset - HII%idg_offset - joff = HIO%jdg_offset - HII%jdg_offset - - Isq = HIO%IscB ; Ieq = HIO%IecB ; Jsq = HIO%JscB ; Jeq = HIO%JecB + Isq = HI%IscB ; Ieq = HI%IecB ; Jsq = HI%JscB ; Jeq = HI%JecB rho_scale = EOS%kg_m3_to_R GxRho = EOS%RL2_T2_to_Pa * G_e * rho_0 @@ -1660,14 +1650,13 @@ subroutine int_density_dz_generic_plm (T_t, T_b, S_t, S_b, z_t, z_b, rho_ref, & ! 1. Compute vertical integrals ! ============================= do j=Jsq,Jeq+1 - jin = j+joff - do i = Isq,Ieq+1 ; iin = i+ioff - dz(i) = z_t(iin,jin) - z_b(iin,jin) + do i = Isq,Ieq+1 + dz(i) = z_t(i,j) - z_b(i,j) do n=1,5 - p5(i*5+n) = -GxRho*(z_t(iin,jin) - 0.25*real(n-1)*dz(i)) + p5(i*5+n) = -GxRho*(z_t(i,j) - 0.25*real(n-1)*dz(i)) ! Salinity and temperature points are linearly interpolated - S5(i*5+n) = wt_t(n) * S_t(iin,jin) + wt_b(n) * S_b(iin,jin) - T5(i*5+n) = wt_t(n) * T_t(iin,jin) + wt_b(n) * T_b(iin,jin) + S5(i*5+n) = wt_t(n) * S_t(i,j) + wt_b(n) * S_b(i,j) + T5(i*5+n) = wt_t(n) * T_t(i,j) + wt_b(n) * T_b(i,j) enddo enddo if (rho_scale /= 1.0) then @@ -1676,7 +1665,7 @@ subroutine int_density_dz_generic_plm (T_t, T_b, S_t, S_b, z_t, z_b, rho_ref, & call calculate_density_array(T5, S5, p5, r5, 1, (ieq-isq+2)*5, EOS, rho_ref=rho_ref_mks) endif - do i=isq,ieq+1 ; iin = i+ioff + do i=isq,ieq+1 ! 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)) dpa(i,j) = G_e*dz(i)*rho_anom @@ -1693,8 +1682,8 @@ 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 + if (present(intx_dpa)) then ; do j=HI%jsc,HI%jec + do I=Isq,Ieq ! 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 @@ -1703,28 +1692,28 @@ subroutine int_density_dz_generic_plm (T_t, T_b, S_t, S_b, z_t, z_b, rho_ref, & ! 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)) + 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(iin,jin) - z_b(iin,jin)) + dz_subroundoff - hR = (z_t(iin+1,jin) - z_b(iin+1,jin)) + dz_subroundoff + hL = (z_t(i,j) - z_b(i,j)) + dz_subroundoff + hR = (z_t(i+1,j) - z_b(i+1,j)) + 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 + Ttl = ( (hWght*hR)*T_t(i+1,j) + (hWght*hL + hR*hL)*T_t(i,j) ) * iDenom + Ttr = ( (hWght*hL)*T_t(i,j) + (hWght*hR + hR*hL)*T_t(i+1,j) ) * iDenom + Tbl = ( (hWght*hR)*T_b(i+1,j) + (hWght*hL + hR*hL)*T_b(i,j) ) * iDenom + Tbr = ( (hWght*hL)*T_b(i,j) + (hWght*hR + hR*hL)*T_b(i+1,j) ) * iDenom + Stl = ( (hWght*hR)*S_t(i+1,j) + (hWght*hL + hR*hL)*S_t(i,j) ) * iDenom + Str = ( (hWght*hL)*S_t(i,j) + (hWght*hR + hR*hL)*S_t(i+1,j) ) * iDenom + Sbl = ( (hWght*hR)*S_b(i+1,j) + (hWght*hL + hR*hL)*S_b(i,j) ) * iDenom + Sbr = ( (hWght*hL)*S_b(i,j) + (hWght*hR + hR*hL)*S_b(i+1,j) ) * 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) + Ttl = T_t(i,j); Tbl = T_b(i,j); Ttr = T_t(i+1,j); Tbr = T_b(i+1,j) + Stl = S_t(i,j); Sbl = S_b(i,j); Str = S_t(i+1,j); Sbr = S_b(i+1,j) 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)) + dz_x(m,i) = w_left*(z_t(i,j) - z_b(i,j)) + w_right*(z_t(i+1,j) - z_b(i+1,j)) ! Salinity and temperature points are linearly interpolated in ! the horizontal. The subscript (1) refers to the top value in @@ -1737,7 +1726,7 @@ subroutine int_density_dz_generic_plm (T_t, T_b, S_t, S_b, z_t, z_b, rho_ref, & 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(i,j) + w_right*z_t(i+1,j)) ! Pressure do n=2,5 @@ -1760,7 +1749,7 @@ subroutine int_density_dz_generic_plm (T_t, T_b, S_t, S_b, z_t, z_b, rho_ref, & call calculate_density(T15, S15, p15, r15, 1, 15*(ieq-isq+1), EOS, rho_ref=rho_ref_mks) endif - do I=Isq,Ieq ; iin = i+ioff + do I=Isq,Ieq intz(1) = dpa(i,j) ; intz(5) = dpa(i+1,j) ! Use Bode's rule to estimate the pressure anomaly change. @@ -1778,8 +1767,8 @@ subroutine int_density_dz_generic_plm (T_t, T_b, S_t, S_b, z_t, z_b, rho_ref, & ! ================================================== ! 3. Compute horizontal integrals in the y direction ! ================================================== - if (present(inty_dpa)) then ; do J=Jsq,Jeq ; jin = j+joff - do i=HIO%isc,HIO%iec ; iin = i+ioff + if (present(inty_dpa)) then ; do J=Jsq,Jeq + do i=HI%isc,HI%iec ! 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 @@ -1788,28 +1777,28 @@ subroutine int_density_dz_generic_plm (T_t, T_b, S_t, S_b, z_t, z_b, rho_ref, & ! 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(i,j)-z_t(iin,jin+1), -bathyT(i,j+1)-z_t(iin,jin)) + 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(iin,jin) - z_b(iin,jin)) + dz_subroundoff - hR = (z_t(iin,jin+1) - z_b(iin,jin+1)) + dz_subroundoff + hL = (z_t(i,j) - z_b(i,j)) + dz_subroundoff + hR = (z_t(i,j+1) - z_b(i,j+1)) + dz_subroundoff hWght = hWght * ( (hL-hR)/(hL+hR) )**2 iDenom = 1./( hWght*(hR + hL) + hL*hR ) - Ttl = ( (hWght*hR)*T_t(iin,jin+1) + (hWght*hL + hR*hL)*T_t(iin,jin) ) * iDenom - Ttr = ( (hWght*hL)*T_t(iin,jin) + (hWght*hR + hR*hL)*T_t(iin,jin+1) ) * iDenom - Tbl = ( (hWght*hR)*T_b(iin,jin+1) + (hWght*hL + hR*hL)*T_b(iin,jin) ) * iDenom - Tbr = ( (hWght*hL)*T_b(iin,jin) + (hWght*hR + hR*hL)*T_b(iin,jin+1) ) * iDenom - Stl = ( (hWght*hR)*S_t(iin,jin+1) + (hWght*hL + hR*hL)*S_t(iin,jin) ) * iDenom - Str = ( (hWght*hL)*S_t(iin,jin) + (hWght*hR + hR*hL)*S_t(iin,jin+1) ) * iDenom - Sbl = ( (hWght*hR)*S_b(iin,jin+1) + (hWght*hL + hR*hL)*S_b(iin,jin) ) * iDenom - Sbr = ( (hWght*hL)*S_b(iin,jin) + (hWght*hR + hR*hL)*S_b(iin,jin+1) ) * iDenom + Ttl = ( (hWght*hR)*T_t(i,j+1) + (hWght*hL + hR*hL)*T_t(i,j) ) * iDenom + Ttr = ( (hWght*hL)*T_t(i,j) + (hWght*hR + hR*hL)*T_t(i,j+1) ) * iDenom + Tbl = ( (hWght*hR)*T_b(i,j+1) + (hWght*hL + hR*hL)*T_b(i,j) ) * iDenom + Tbr = ( (hWght*hL)*T_b(i,j) + (hWght*hR + hR*hL)*T_b(i,j+1) ) * iDenom + Stl = ( (hWght*hR)*S_t(i,j+1) + (hWght*hL + hR*hL)*S_t(i,j) ) * iDenom + Str = ( (hWght*hL)*S_t(i,j) + (hWght*hR + hR*hL)*S_t(i,j+1) ) * iDenom + Sbl = ( (hWght*hR)*S_b(i,j+1) + (hWght*hL + hR*hL)*S_b(i,j) ) * iDenom + Sbr = ( (hWght*hL)*S_b(i,j) + (hWght*hR + hR*hL)*S_b(i,j+1) ) * iDenom else - Ttl = T_t(iin,jin); Tbl = T_b(iin,jin); Ttr = T_t(iin,jin+1); Tbr = T_b(iin,jin+1) - Stl = S_t(iin,jin); Sbl = S_b(iin,jin); Str = S_t(iin,jin+1); Sbr = S_b(iin,jin+1) + Ttl = T_t(i,j); Tbl = T_b(i,j); Ttr = T_t(i,j+1); Tbr = T_b(i,j+1) + Stl = S_t(i,j); Sbl = S_b(i,j); Str = S_t(i,j+1); Sbr = S_b(i,j+1) endif do m=2,4 w_left = 0.25*real(5-m) ; w_right = 1.0-w_left - dz_y(m,i) = w_left*(z_t(iin,jin) - z_b(iin,jin)) + w_right*(z_t(iin,jin+1) - z_b(iin,jin+1)) + dz_y(m,i) = w_left*(z_t(i,j) - z_b(i,j)) + w_right*(z_t(i,j+1) - z_b(i,j+1)) ! Salinity and temperature points are linearly interpolated in ! the horizontal. The subscript (1) refers to the top value in @@ -1822,7 +1811,7 @@ subroutine int_density_dz_generic_plm (T_t, T_b, S_t, S_b, z_t, z_b, rho_ref, & 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,jin+1)) + p15(pos+1) = -GxRho*(w_left*z_t(i,j) + w_right*z_t(i,j+1)) ! Pressure do n=2,5 ; p15(pos+n) = p15(pos+n-1) + GxRho*0.25*dz_y(m,i) ; enddo @@ -1838,14 +1827,14 @@ subroutine int_density_dz_generic_plm (T_t, T_b, S_t, S_b, z_t, z_b, rho_ref, & enddo if (rho_scale /= 1.0) then - 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, & + call calculate_density_array(T15(15*HI%isc+1:), S15(15*HI%isc+1:), p15(15*HI%isc+1:), & + r15(15*HI%isc+1:), 1, 15*(HI%iec-HI%isc+1), EOS, & rho_ref=rho_ref_mks, scale=rho_scale) else - 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, rho_ref=rho_ref_mks) + call calculate_density_array(T15(15*HI%isc+1:), S15(15*HI%isc+1:), p15(15*HI%isc+1:), & + r15(15*HI%isc+1:), 1, 15*(HI%iec-HI%isc+1), EOS, rho_ref=rho_ref_mks) endif - do i=HIO%isc,HIO%iec ; iin = i+ioff + do i=HI%isc,HI%iec intz(1) = dpa(i,j) ; intz(5) = dpa(i,j+1) ! Use Bode's rule to estimate the pressure anomaly change. @@ -1995,26 +1984,25 @@ end function frac_dp_at_pos !> Compute pressure gradient force integrals for the case where T and S !! are parabolic profiles subroutine int_density_dz_generic_ppm(T, T_t, T_b, S, S_t, S_b, & - z_t, z_b, rho_ref, rho_0, G_e, HII, HIO, & + 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) :: HII !< Ocean horizontal index structures for the input arrays - type(hor_index_type), intent(in) :: HIO !< Ocean horizontal index structures for the output arrays - real, dimension(HII%isd:HII%ied,HII%jsd:HII%jed), & + type(hor_index_type), intent(in) :: HI !< Ocean horizontal index structures for the arrays + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & intent(in) :: T !< Potential temperature referenced to the surface [degC] - real, dimension(HII%isd:HII%ied,HII%jsd:HII%jed), & + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & intent(in) :: T_t !< Potential temperatue at the cell top [degC] - real, dimension(HII%isd:HII%ied,HII%jsd:HII%jed), & + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & intent(in) :: T_b !< Potential temperatue at the cell bottom [degC] - real, dimension(HII%isd:HII%ied,HII%jsd:HII%jed), & + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & intent(in) :: S !< Salinity [ppt] - real, dimension(HII%isd:HII%ied,HII%jsd:HII%jed), & + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & intent(in) :: S_t !< Salinity at the cell top [ppt] - real, dimension(HII%isd:HII%ied,HII%jsd:HII%jed), & + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & intent(in) :: S_b !< Salinity at the cell bottom [ppt] - real, dimension(HII%isd:HII%ied,HII%jsd:HII%jed), & + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & intent(in) :: z_t !< Height at the top of the layer [Z ~> m] - real, dimension(HII%isd:HII%ied,HII%jsd:HII%jed), & + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & intent(in) :: z_b !< Height at the bottom of the layer [Z ~> m] real, intent(in) :: rho_ref !< A mean density [R ~> kg m-3] or [kg m-3], that is !! subtracted out to reduce the magnitude of each of the integrals. @@ -2022,17 +2010,17 @@ subroutine int_density_dz_generic_ppm(T, T_t, T_b, S, S_t, S_b, & !! 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 [m s-2] type(EOS_type), pointer :: EOS !< Equation of state structure - real, dimension(HIO%isd:HIO%ied,HIO%jsd:HIO%jed), & + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & intent(inout) :: dpa !< The change in the pressure anomaly across the layer [R L2 T-2 ~> Pa] - real, dimension(HIO%isd:HIO%ied,HIO%jsd:HIO%jed), & + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & optional, intent(inout) :: intz_dpa !< The integral through the thickness of the layer of !! the pressure anomaly relative to the anomaly at the !! top of the layer [R L2 Z T-2 ~> Pa m] - real, dimension(HIO%IsdB:HIO%IedB,HIO%jsd:HIO%jed), & + real, dimension(HI%IsdB:HI%IedB,HI%jsd:HI%jed), & optional, intent(inout) :: 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 [R L2 T-2 ~> Pa] - real, dimension(HIO%isd:HIO%ied,HIO%JsdB:HIO%JedB), & + real, dimension(HI%isd:HI%ied,HI%JsdB:HI%JedB), & optional, intent(inout) :: 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 [R L2 T-2 ~> Pa] @@ -2070,7 +2058,7 @@ subroutine int_density_dz_generic_ppm(T, T_t, T_b, S, S_t, S_b, & real :: xi ! normalized coordinate real :: T_top, T_mid, T_bot real :: S_top, S_mid, S_bot - integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, i, j, m, n, ioff, joff + integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, i, j, m, n real, dimension(4) :: x, y real, dimension(9) :: S_node, T_node, p_node, r_node @@ -2078,15 +2066,12 @@ subroutine int_density_dz_generic_ppm(T, T_t, T_b, S, S_t, S_b, & call MOM_error(FATAL, & "int_density_dz_generic_ppm: the implementation is not done yet, contact developer") - ioff = HIO%idg_offset - HII%idg_offset - joff = HIO%jdg_offset - HII%jdg_offset - ! These array bounds work for the indexing convention of the input arrays, but ! on the computational domain defined for the output arrays. - Isq = HIO%IscB + ioff ; Ieq = HIO%IecB + ioff - Jsq = HIO%JscB + joff ; Jeq = HIO%JecB + joff - is = HIO%isc + ioff ; ie = HIO%iec + ioff - js = HIO%jsc + joff ; je = HIO%jec + joff + Isq = HI%IscB ; Ieq = HI%IecB + Jsq = HI%JscB ; Jeq = HI%JecB + is = HI%isc ; ie = HI%iec + js = HI%jsc ; je = HI%jec rho_scale = EOS%kg_m3_to_R GxRho = EOS%RL2_T2_to_Pa * G_e * rho_0 @@ -2127,7 +2112,7 @@ subroutine int_density_dz_generic_ppm(T, T_t, T_b, S, S_t, S_b, & ! 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)) - dpa(i-ioff,j-joff) = G_e*dz*rho_anom + 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. @@ -2140,7 +2125,7 @@ subroutine int_density_dz_generic_ppm(T, T_t, T_b, S, S_t, S_b, & ! 2. Compute horizontal integrals in the x direction ! ================================================== if (present(intx_dpa)) then ; do j=js,je ; do I=Isq,Ieq - intz(1) = dpa(i-ioff,j-joff) ; intz(5) = dpa(i+1-ioff,j-joff) + intz(1) = dpa(i,j) ; intz(5) = dpa(i+1,j) 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)) @@ -2191,7 +2176,7 @@ subroutine int_density_dz_generic_ppm(T, T_t, T_b, S, S_t, S_b, & intz(m) = G_e*dz*( C1_90*(7.0*(r5(1)+r5(5)) + 32.0*(r5(2)+r5(4)) + & 12.0*r5(3)) ) enddo - intx_dpa(i-ioff,j-joff) = C1_90*(7.0*(intz(1)+intz(5)) + 32.0*(intz(2)+intz(4)) + & + intx_dpa(i,j) = C1_90*(7.0*(intz(1)+intz(5)) + 32.0*(intz(2)+intz(4)) + & 12.0*intz(3)) ! Use Gauss quadrature rule to compute integral @@ -2239,9 +2224,9 @@ subroutine int_density_dz_generic_ppm(T, T_t, T_b, S, S_t, S_b, & endif 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,j) ) - intx_dpa(i-ioff,j-joff) = intx_dpa(i-ioff,j-joff) * G_e + intx_dpa(i,j) = intx_dpa(i,j) * G_e enddo ; enddo ; endif @@ -2252,7 +2237,7 @@ subroutine int_density_dz_generic_ppm(T, T_t, T_b, S, S_t, S_b, & call MOM_error(WARNING, "int_density_dz_generic_ppm still needs to be written for inty_dpa!") do J=Jsq,Jeq ; do i=is,ie - inty_dpa(i-ioff,j-joff) = 0.0 + inty_dpa(i,j) = 0.0 enddo ; enddo endif diff --git a/src/equation_of_state/MOM_EOS_Wright.F90 b/src/equation_of_state/MOM_EOS_Wright.F90 index cd590aa611..57bde3938d 100644 --- a/src/equation_of_state/MOM_EOS_Wright.F90 +++ b/src/equation_of_state/MOM_EOS_Wright.F90 @@ -406,19 +406,18 @@ end subroutine calculate_compress_wright !> 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. -subroutine int_density_dz_wright(T, S, z_t, z_b, rho_ref, rho_0, G_e, HII, HIO, & +subroutine int_density_dz_wright(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & dpa, intz_dpa, intx_dpa, inty_dpa, & bathyT, dz_neglect, useMassWghtInterp, rho_scale, pres_scale) - type(hor_index_type), intent(in) :: HII !< The horizontal index type for the input arrays. - type(hor_index_type), intent(in) :: HIO !< The horizontal index type for the output arrays. - real, dimension(HII%isd:HII%ied,HII%jsd:HII%jed), & + type(hor_index_type), intent(in) :: HI !< The horizontal index type for the arrays. + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & intent(in) :: T !< Potential temperature relative to the surface !! [degC]. - real, dimension(HII%isd:HII%ied,HII%jsd:HII%jed), & + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & intent(in) :: S !< Salinity [PSU]. - real, dimension(HII%isd:HII%ied,HII%jsd:HII%jed), & + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & intent(in) :: z_t !< Height at the top of the layer in depth units [Z ~> m]. - real, dimension(HII%isd:HII%ied,HII%jsd:HII%jed), & + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & intent(in) :: z_b !< Height at the top of the layer [Z ~> m]. real, intent(in) :: rho_ref !< A mean density [R ~> kg m-3] or [kg m-3], that is subtracted !! out to reduce the magnitude of each of the integrals. @@ -428,22 +427,22 @@ subroutine int_density_dz_wright(T, S, z_t, z_b, rho_ref, rho_0, G_e, HII, HIO, !! used in the equation of state. real, intent(in) :: G_e !< The Earth's gravitational acceleration !! [L2 Z-1 T-2 ~> m s-2] or [m2 Z-1 s-2 ~> m s-2]. - real, dimension(HIO%isd:HIO%ied,HIO%jsd:HIO%jed), & + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & intent(inout) :: dpa !< The change in the pressure anomaly across the !! layer [R L2 T-2 ~> Pa] or [Pa]. - real, dimension(HIO%isd:HIO%ied,HIO%jsd:HIO%jed), & + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & optional, intent(inout) :: intz_dpa !< The integral through the thickness of the layer !! of the pressure anomaly relative to the anomaly !! at the top of the layer [R Z L2 T-2 ~> Pa m]. - real, dimension(HIO%IsdB:HIO%IedB,HIO%jsd:HIO%jed), & + real, dimension(HI%IsdB:HI%IedB,HI%jsd:HI%jed), & optional, intent(inout) :: 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 [R L2 T-2 ~> Pa]. - real, dimension(HIO%isd:HIO%ied,HIO%JsdB:HIO%JedB), & + real, dimension(HI%isd:HI%ied,HI%JsdB:HI%JedB), & optional, intent(inout) :: 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 [R L2 T-2 ~> Pa]. - real, dimension(HII%isd:HII%ied,HII%jsd:HII%jed), & + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & optional, intent(in) :: bathyT !< The depth of the bathymetry [Z ~> m]. real, optional, intent(in) :: dz_neglect !< A miniscule thickness change [Z ~> m]. logical, optional, intent(in) :: useMassWghtInterp !< If true, uses mass weighting to @@ -454,7 +453,7 @@ subroutine int_density_dz_wright(T, S, z_t, z_b, rho_ref, rho_0, G_e, HII, HIO, !! into Pa [Pa T2 R-1 L-2 ~> 1]. ! Local variables - real, dimension(HII%isd:HII%ied,HII%jsd:HII%jed) :: al0_2d, p0_2d, lambda_2d + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed) :: al0_2d, p0_2d, lambda_2d real :: al0, p0, lambda real :: rho_anom ! The density anomaly from rho_ref [kg m-3]. real :: eps, eps2, rem @@ -478,17 +477,14 @@ subroutine int_density_dz_wright(T, S, z_t, z_b, rho_ref, rho_0, G_e, HII, HIO, 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 :: 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 + integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, i, j, m ! These array bounds work for the indexing convention of the input arrays, but ! on the computational domain defined for the output arrays. - Isq = HIO%IscB + ioff ; Ieq = HIO%IecB + ioff - Jsq = HIO%JscB + joff ; Jeq = HIO%JecB + joff - is = HIO%isc + ioff ; ie = HIO%iec + ioff - js = HIO%jsc + joff ; je = HIO%jec + joff + Isq = HI%IscB ; Ieq = HI%IecB + Jsq = HI%JscB ; Jeq = HI%JecB + is = HI%isc ; ie = HI%iec + js = HI%jsc ; je = HI%jec if (present(pres_scale)) then GxRho = pres_scale * G_e * rho_0 ; g_Earth = pres_scale * G_e @@ -532,9 +528,9 @@ subroutine int_density_dz_wright(T, S, z_t, z_b, rho_ref, rho_0, G_e, HII, HIO, rho_anom = (p0 + p_ave)*(I_Lzz*I_al0) - rho_ref_mks rem = I_Rho * (lambda * I_al0**2) * eps2 * & (C1_3 + eps2*(0.2 + eps2*(C1_7 + C1_9*eps2))) - dpa(i-ioff,j-joff) = Pa_to_RL2_T2 * (g_Earth*rho_anom*dz - 2.0*eps*rem) + dpa(i,j) = Pa_to_RL2_T2 * (g_Earth*rho_anom*dz - 2.0*eps*rem) if (present(intz_dpa)) & - intz_dpa(i-ioff,j-joff) = Pa_to_RL2_T2 * (0.5*g_Earth*rho_anom*dz**2 - dz*(1.0+eps)*rem) + intz_dpa(i,j) = Pa_to_RL2_T2 * (0.5*g_Earth*rho_anom*dz**2 - dz*(1.0+eps)*rem) enddo ; enddo if (present(intx_dpa)) then ; do j=js,je ; do I=Isq,Ieq @@ -555,7 +551,7 @@ subroutine int_density_dz_wright(T, S, z_t, z_b, rho_ref, rho_0, G_e, HII, HIO, 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) + intz(1) = dpa(i,j) ; intz(5) = dpa(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 @@ -576,7 +572,7 @@ subroutine int_density_dz_wright(T, S, z_t, z_b, rho_ref, rho_0, G_e, HII, HIO, I_Rho * (lambda * I_al0**2) * eps2 * (C1_3 + eps2*(0.2 + eps2*(C1_7 + C1_9*eps2))) ) 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)) + intx_dpa(i,j) = C1_90*(7.0*(intz(1)+intz(5)) + 32.0*(intz(2)+intz(4)) + 12.0*intz(3)) enddo ; enddo ; endif if (present(inty_dpa)) then ; do J=Jsq,Jeq ; do i=is,ie @@ -597,7 +593,7 @@ subroutine int_density_dz_wright(T, S, z_t, z_b, rho_ref, rho_0, G_e, HII, HIO, 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) + intz(1) = dpa(i,j) ; intz(5) = dpa(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 @@ -618,7 +614,7 @@ subroutine int_density_dz_wright(T, S, z_t, z_b, rho_ref, rho_0, G_e, HII, HIO, I_Rho * (lambda * I_al0**2) * eps2 * (C1_3 + eps2*(0.2 + eps2*(C1_7 + C1_9*eps2))) ) 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)) + inty_dpa(i,j) = C1_90*(7.0*(intz(1)+intz(5)) + 32.0*(intz(2)+intz(4)) + 12.0*intz(3)) enddo ; enddo ; endif end subroutine int_density_dz_wright diff --git a/src/equation_of_state/MOM_EOS_linear.F90 b/src/equation_of_state/MOM_EOS_linear.F90 index 623db27ad3..e3a5443840 100644 --- a/src/equation_of_state/MOM_EOS_linear.F90 +++ b/src/equation_of_state/MOM_EOS_linear.F90 @@ -325,19 +325,18 @@ end subroutine calculate_compress_linear !> 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. -subroutine int_density_dz_linear(T, S, z_t, z_b, rho_ref, rho_0_pres, G_e, HII, HIO, & +subroutine int_density_dz_linear(T, S, z_t, z_b, rho_ref, rho_0_pres, G_e, HI, & 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 !< The horizontal index type for the input arrays. - type(hor_index_type), intent(in) :: HIO !< The horizontal index type for the output arrays. - real, dimension(HII%isd:HII%ied,HII%jsd:HII%jed), & + type(hor_index_type), intent(in) :: HI !< The horizontal index type for the arrays. + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & intent(in) :: T !< Potential temperature relative to the surface !! [degC]. - real, dimension(HII%isd:HII%ied,HII%jsd:HII%jed), & + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & intent(in) :: S !< Salinity [PSU]. - real, dimension(HII%isd:HII%ied,HII%jsd:HII%jed), & + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & intent(in) :: z_t !< Height at the top of the layer in depth units [Z ~> m]. - real, dimension(HII%isd:HII%ied,HII%jsd:HII%jed), & + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & intent(in) :: z_b !< Height at the top of the layer [Z ~> m]. real, intent(in) :: rho_ref !< A mean density [R ~> kg m-3] or [kg m-3], that !! is subtracted out to reduce the magnitude of @@ -352,22 +351,22 @@ subroutine int_density_dz_linear(T, S, z_t, z_b, rho_ref, rho_0_pres, G_e, HII, !! [R degC-1 ~> kg m-3 degC-1] or [kg m-3 degC-1]. real, intent(in) :: dRho_dS !< The derivative of density with salinity, !! in [R ppt-1 ~> kg m-3 ppt-1] or [kg m-3 ppt-1]. - real, dimension(HIO%isd:HIO%ied,HIO%jsd:HIO%jed), & + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & intent(out) :: dpa !< The change in the pressure anomaly across the !! layer [R L2 T-2 ~> Pa] or [Pa]. - real, dimension(HIO%isd:HIO%ied,HIO%jsd:HIO%jed), & + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & 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 [R L2 Z T-2 ~> Pa Z] or [Pa Z]. - real, dimension(HIO%IsdB:HIO%IedB,HIO%jsd:HIO%jed), & + real, dimension(HI%IsdB:HI%IedB,HI%jsd:HI%jed), & 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 [R L2 T-2 ~> Pa] or [Pa]. - real, dimension(HIO%isd:HIO%ied,HIO%JsdB:HIO%JedB), & + real, dimension(HI%isd:HI%ied,HI%JsdB:HI%JedB), & 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 [R L2 T-2 ~> Pa] or [Pa]. - real, dimension(HII%isd:HII%ied,HII%jsd:HII%jed), & + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & optional, intent(in) :: bathyT !< The depth of the bathymetry [Z ~> m]. real, optional, intent(in) :: dz_neglect !< A miniscule thickness change [Z ~> m]. logical, optional, intent(in) :: useMassWghtInterp !< If true, uses mass weighting to @@ -388,17 +387,14 @@ subroutine int_density_dz_linear(T, S, z_t, z_b, rho_ref, rho_0_pres, G_e, HII, ! 5 sub-column locations [R L2 T-2 ~> Pa] or [Pa]. 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 + integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, i, j, m ! These array bounds work for the indexing convention of the input arrays, but ! on the computational domain defined for the output arrays. - Isq = HIO%IscB + ioff ; Ieq = HIO%IecB + ioff - Jsq = HIO%JscB + joff ; Jeq = HIO%JecB + joff - is = HIO%isc + ioff ; ie = HIO%iec + ioff - js = HIO%jsc + joff ; je = HIO%jec + joff + Isq = HI%IscB ; Ieq = HI%IecB + Jsq = HI%JscB ; Jeq = HI%JecB + is = HI%isc ; ie = HI%iec + js = HI%jsc ; je = HI%jec do_massWeight = .false. if (present(useMassWghtInterp)) then ; if (useMassWghtInterp) then @@ -412,8 +408,8 @@ subroutine int_density_dz_linear(T, S, z_t, z_b, rho_ref, rho_0_pres, G_e, HII, do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 dz = z_t(i,j) - z_b(i,j) rho_anom = (Rho_T0_S0 - rho_ref) + dRho_dT*T(i,j) + dRho_dS*S(i,j) - dpa(i-ioff,j-joff) = G_e*rho_anom*dz - if (present(intz_dpa)) intz_dpa(i-ioff,j-joff) = 0.5*G_e*rho_anom*dz**2 + dpa(i,j) = G_e*rho_anom*dz + if (present(intz_dpa)) intz_dpa(i,j) = 0.5*G_e*rho_anom*dz**2 enddo ; enddo if (present(intx_dpa)) then ; do j=js,je ; do I=Isq,Ieq @@ -429,7 +425,7 @@ subroutine int_density_dz_linear(T, S, z_t, z_b, rho_ref, rho_0_pres, G_e, HII, 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)) + intx_dpa(i,j) = 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 @@ -438,7 +434,7 @@ subroutine int_density_dz_linear(T, S, z_t, z_b, rho_ref, rho_0_pres, G_e, HII, 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) + intz(1) = dpa(i,j) ; intz(5) = dpa(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 @@ -450,7 +446,7 @@ subroutine int_density_dz_linear(T, S, z_t, z_b, rho_ref, rho_0_pres, G_e, HII, 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)) + & + intx_dpa(i,j) = C1_90*(7.0*(intz(1)+intz(5)) + 32.0*(intz(2)+intz(4)) + & 12.0*intz(3)) endif enddo ; enddo ; endif @@ -468,7 +464,7 @@ subroutine int_density_dz_linear(T, S, z_t, z_b, rho_ref, rho_0_pres, G_e, HII, 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)) + inty_dpa(i,j) = 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 @@ -477,7 +473,7 @@ subroutine int_density_dz_linear(T, S, z_t, z_b, rho_ref, rho_0_pres, G_e, HII, 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) + intz(1) = dpa(i,j) ; intz(5) = dpa(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 @@ -489,7 +485,7 @@ subroutine int_density_dz_linear(T, S, z_t, z_b, rho_ref, rho_0_pres, G_e, HII, 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)) + & + inty_dpa(i,j) = C1_90*(7.0*(intz(1)+intz(5)) + 32.0*(intz(2)+intz(4)) + & 12.0*intz(3)) endif From 5f7ce525b3b9b1e984cbaae4db4f37831d8696e3 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 30 Apr 2020 18:53:05 -0400 Subject: [PATCH 247/316] (*)Rescale frazil and p_surf_prev after restarts Added code to rescale frazil and p_surf_prev after restarts if the dimensional rescaling factors have changed. All answers are bitwise identical in test cases but there are some peculiar instances when incorrect behavior is avoided. --- src/core/MOM.F90 | 32 ++++++++++++++++++++++++++++++-- 1 file changed, 30 insertions(+), 2 deletions(-) diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index 77b8bdd7d8..34266b51ab 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -1670,6 +1670,7 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & integer :: dynamics_stencil ! The computational stencil for the calculations ! in the dynamic core. real :: conv2watt, conv2salt + real :: RL2_T2_rescale, Z_rescale, QRZ_rescale ! Unit conversion factors character(len=48) :: flux_units, S_flux_units type(vardesc) :: vd_T, vd_S ! Structures describing temperature and salinity variables. @@ -2665,14 +2666,39 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & call register_obsolete_diagnostics(param_file, CS%diag) if (use_frazil) then - if (.not.query_initialized(CS%tv%frazil,"frazil",restart_CSp)) & + if (.not.query_initialized(CS%tv%frazil,"frazil",restart_CSp)) then + ! Test whether the dimensional rescaling has changed for heat content. + if ((US%kg_m3_to_R_restart*US%m_to_Z_restart*US%J_kg_to_Q_restart /= 0.0) .and. & + ((US%J_kg_to_Q*US%kg_m3_to_R*US%m_to_Z) /= & + (US%J_kg_to_Q_restart*US%kg_m3_to_R_restart*US%m_to_Z_restart)) ) then + QRZ_rescale = (US%J_kg_to_Q*US%kg_m3_to_R*US%m_to_Z) / & + (US%J_kg_to_Q_restart*US%kg_m3_to_R_restart*US%m_to_Z_restart) + do j=js,je ; do i=is,ie + CS%tv%frazil(i,j) = QRZ_rescale * CS%tv%frazil(i,j) + enddo ; enddo + endif + else CS%tv%frazil(:,:) = 0.0 + endif endif if (CS%interp_p_surf) then CS%p_surf_prev_set = query_initialized(CS%p_surf_prev,"p_surf_prev",restart_CSp) - if (CS%p_surf_prev_set) call pass_var(CS%p_surf_prev, G%domain) + if (CS%p_surf_prev_set) then + ! Test whether the dimensional rescaling has changed for pressure. + if ((US%kg_m3_to_R_restart*US%s_to_T_restart*US%m_to_L_restart /= 0.0) .and. & + ((US%kg_m3_to_R*(US%m_to_L*US%s_to_T_restart)**2) /= & + (US%kg_m3_to_R_restart*(US%m_to_L_restart*US%s_to_T)**2)) ) then + RL2_T2_rescale = (US%kg_m3_to_R*(US%m_to_L*US%s_to_T_restart)**2) / & + (US%kg_m3_to_R_restart*(US%m_to_L_restart*US%s_to_T)**2) + do j=js,je ; do i=is,ie + CS%p_surf_prev(i,j) = RL2_T2_rescale * CS%p_surf_prev(i,j) + enddo ; enddo + endif + + call pass_var(CS%p_surf_prev, G%domain) + endif endif if (.not.query_initialized(CS%ave_ssh_ibc,"ave_ssh",restart_CSp)) then @@ -2891,6 +2917,8 @@ subroutine set_restart_fields(GV, US, param_file, CS, restart_CSp) "Time unit conversion factor", "T second-1") call register_restart_field(US%kg_m3_to_R_restart, "kg_m3_to_R", .false., restart_CSp, & "Density unit conversion factor", "R m3 kg-1") + call register_restart_field(US%J_kg_to_Q_restart, "J_kg_to_Q", .false., restart_CSp, & + "Heat content unit conversion factor.", units="Q kg J-1") end subroutine set_restart_fields From a90a65ec8898a99bbef83e659b336cbf2c89fa8f Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 30 Apr 2020 18:56:45 -0400 Subject: [PATCH 248/316] +(*)Added US and m_to_BLD_units args to KPP_get_BLD Added a unit scaling type argument and an optional argument, m_to_BLD_units, to specify the units with which KPP_get_BLD returns the mixed layer depths. Also change the default units of the turbulent boundary layer depths returned from KPP_get_BLD and energetic_PBL_get_MLD to [Z]. In addition, corrected the documented units for various variables related to the recently added MOM_lateral_boundary_diffusion module. All answers are bitwise identical by default and in the MOM6-examples test cases, but some improper dimensional rescaling has been corrected for non-Boussinesq configurations using MOM_lateral_boundary_diffusion. --- .../vertical/MOM_CVMix_KPP.F90 | 16 +++- .../vertical/MOM_diabatic_driver.F90 | 18 ++-- .../vertical/MOM_energetic_PBL.F90 | 10 +-- src/tracer/MOM_lateral_boundary_diffusion.F90 | 88 ++++++++++--------- src/tracer/MOM_neutral_diffusion.F90 | 7 +- src/tracer/MOM_tracer_hor_diff.F90 | 8 +- 6 files changed, 80 insertions(+), 67 deletions(-) diff --git a/src/parameterizations/vertical/MOM_CVMix_KPP.F90 b/src/parameterizations/vertical/MOM_CVMix_KPP.F90 index 6ff6046350..3b7420aa54 100644 --- a/src/parameterizations/vertical/MOM_CVMix_KPP.F90 +++ b/src/parameterizations/vertical/MOM_CVMix_KPP.F90 @@ -1365,17 +1365,25 @@ end subroutine KPP_smooth_BLD -!> Copies KPP surface boundary layer depth into BLD -subroutine KPP_get_BLD(CS, BLD, G) +!> Copies KPP surface boundary layer depth into BLD, in units of [Z ~> m] unless other units are specified. +subroutine KPP_get_BLD(CS, BLD, G, US, m_to_BLD_units) type(KPP_CS), pointer :: CS !< Control structure for !! this module type(ocean_grid_type), intent(in) :: G !< Grid structure - real, dimension(SZI_(G),SZJ_(G)), intent(inout) :: BLD!< bnd. layer depth [m] + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(G),SZJ_(G)), intent(inout) :: BLD !< Boundary layer depth [Z ~> m] or other units + real, optional, intent(in) :: m_to_BLD_units !< A conversion factor from meters + !! to the desired units for BLD ! Local variables + real :: scale ! A dimensional rescaling factor integer :: i,j + + scale = US%m_to_Z ; if (present(m_to_BLD_units)) scale = m_to_BLD_units + do j = G%jsc, G%jec ; do i = G%isc, G%iec - BLD(i,j) = CS%OBLdepth(i,j) + BLD(i,j) = scale * CS%OBLdepth(i,j) enddo ; enddo + end subroutine KPP_get_BLD !> Apply KPP non-local transport of surface fluxes for temperature. diff --git a/src/parameterizations/vertical/MOM_diabatic_driver.F90 b/src/parameterizations/vertical/MOM_diabatic_driver.F90 index 69c800d218..3c017c0f6c 100644 --- a/src/parameterizations/vertical/MOM_diabatic_driver.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_driver.F90 @@ -663,9 +663,7 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Tim Kd_salt, visc%Kv_shear, CS%KPP_NLTheat, CS%KPP_NLTscalar, Waves=Waves) if (associated(Hml)) then - !$OMP parallel default(shared) - call KPP_get_BLD(CS%KPP_CSp, Hml(:,:), G) - !$OMP end parallel + call KPP_get_BLD(CS%KPP_CSp, Hml(:,:), G, US, m_to_BLD_units=1.0) call pass_var(Hml, G%domain, halo=1) ! If visc%MLD exists, copy KPP's BLD into it if (associated(visc%MLD)) visc%MLD(:,:) = Hml(:,:) @@ -842,12 +840,12 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Tim CS%energetic_PBL_CSp, dSV_dT, dSV_dS, cTKE, SkinBuoyFlux, waves=waves) if (associated(Hml)) then - call energetic_PBL_get_MLD(CS%energetic_PBL_CSp, Hml(:,:), G, US) + call energetic_PBL_get_MLD(CS%energetic_PBL_CSp, Hml(:,:), G, US, m_to_MLD_units=1.0) call pass_var(Hml, G%domain, halo=1) ! If visc%MLD exists, copy ePBL's MLD into it if (associated(visc%MLD)) visc%MLD(:,:) = Hml(:,:) elseif (associated(visc%MLD)) then - call energetic_PBL_get_MLD(CS%energetic_PBL_CSp, visc%MLD, G, US) + call energetic_PBL_get_MLD(CS%energetic_PBL_CSp, visc%MLD, G, US, m_to_MLD_units=1.0) call pass_var(visc%MLD, G%domain, halo=1) endif @@ -1448,9 +1446,7 @@ subroutine diabatic_ALE(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, Kd_salt, visc%Kv_shear, CS%KPP_NLTheat, CS%KPP_NLTscalar, Waves=Waves) if (associated(Hml)) then - !$OMP parallel default(shared) - call KPP_get_BLD(CS%KPP_CSp, Hml(:,:), G) - !$OMP end parallel + call KPP_get_BLD(CS%KPP_CSp, Hml(:,:), G, US, m_to_BLD_units=1.0) call pass_var(Hml, G%domain, halo=1) ! If visc%MLD exists, copy KPP's BLD into it if (associated(visc%MLD)) visc%MLD(:,:) = Hml(:,:) @@ -1573,12 +1569,12 @@ subroutine diabatic_ALE(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, CS%energetic_PBL_CSp, dSV_dT, dSV_dS, cTKE, SkinBuoyFlux, waves=waves) if (associated(Hml)) then - call energetic_PBL_get_MLD(CS%energetic_PBL_CSp, Hml(:,:), G, US) + call energetic_PBL_get_MLD(CS%energetic_PBL_CSp, Hml(:,:), G, US, m_to_MLD_units=1.0) call pass_var(Hml, G%domain, halo=1) ! If visc%MLD exists, copy ePBL's MLD into it if (associated(visc%MLD)) visc%MLD(:,:) = Hml(:,:) elseif (associated(visc%MLD)) then - call energetic_PBL_get_MLD(CS%energetic_PBL_CSp, visc%MLD, G, US) + call energetic_PBL_get_MLD(CS%energetic_PBL_CSp, visc%MLD, G, US, m_to_MLD_units=1.0) call pass_var(visc%MLD, G%domain, halo=1) endif @@ -2183,7 +2179,7 @@ subroutine layered_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_e Kd_salt, visc%Kv_shear, CS%KPP_NLTheat, CS%KPP_NLTscalar, Waves=Waves) if (associated(Hml)) then - call KPP_get_BLD(CS%KPP_CSp, Hml(:,:), G) + call KPP_get_BLD(CS%KPP_CSp, Hml(:,:), G, US, m_to_BLD_units=1.0) call pass_var(Hml, G%domain, halo=1) ! If visc%MLD exists, copy KPP's BLD into it if (associated(visc%MLD)) visc%MLD(:,:) = Hml(:,:) diff --git a/src/parameterizations/vertical/MOM_energetic_PBL.F90 b/src/parameterizations/vertical/MOM_energetic_PBL.F90 index 48b265a0e2..a9e68736e7 100644 --- a/src/parameterizations/vertical/MOM_energetic_PBL.F90 +++ b/src/parameterizations/vertical/MOM_energetic_PBL.F90 @@ -1908,19 +1908,19 @@ subroutine Mstar_Langmuir(CS, US, Abs_Coriolis, Buoyancy_Flux, UStar, BLD, Langm end subroutine Mstar_Langmuir -!> Copies the ePBL active mixed layer depth into MLD +!> Copies the ePBL active mixed layer depth into MLD, in units of [Z ~> m] unless other units are specified. subroutine energetic_PBL_get_MLD(CS, MLD, G, US, m_to_MLD_units) type(energetic_PBL_CS), pointer :: CS !< Control structure for ePBL type(ocean_grid_type), intent(in) :: G !< Grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - real, dimension(SZI_(G),SZJ_(G)), intent(out) :: MLD !< Depth of ePBL active mixing layer [m or other units] - real, optional, intent(in) :: m_to_MLD_units !< A conversion factor to the - !! desired units for MLD + real, dimension(SZI_(G),SZJ_(G)), intent(out) :: MLD !< Depth of ePBL active mixing layer [Z ~> m] or other units + real, optional, intent(in) :: m_to_MLD_units !< A conversion factor from meters + !! to the desired units for MLD ! Local variables real :: scale ! A dimensional rescaling factor integer :: i,j - scale = US%Z_to_m ; if (present(m_to_MLD_units)) scale = scale * m_to_MLD_units + scale = 1.0 ; if (present(m_to_MLD_units)) scale = US%Z_to_m * m_to_MLD_units do j=G%jsc,G%jec ; do i=G%isc,G%iec MLD(i,j) = scale*CS%ML_Depth(i,j) diff --git a/src/tracer/MOM_lateral_boundary_diffusion.F90 b/src/tracer/MOM_lateral_boundary_diffusion.F90 index d06127d0d5..8b9be533d5 100644 --- a/src/tracer/MOM_lateral_boundary_diffusion.F90 +++ b/src/tracer/MOM_lateral_boundary_diffusion.F90 @@ -134,15 +134,15 @@ subroutine lateral_boundary_diffusion(G, GV, US, h, Coef_x, Coef_y, dt, Reg, CS) type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & intent(in) :: h !< Layer thickness [H ~> m or kg m-2] - real, dimension(SZIB_(G),SZJ_(G)), intent(in) :: Coef_x !< dt * Kh * dy / dx at u-points [m2] - real, dimension(SZI_(G),SZJB_(G)), intent(in) :: Coef_y !< dt * Kh * dx / dy at v-points [m2] + real, dimension(SZIB_(G),SZJ_(G)), intent(in) :: Coef_x !< dt * Kh * dy / dx at u-points [L2 ~> m2] + real, dimension(SZI_(G),SZJB_(G)), intent(in) :: Coef_y !< dt * Kh * dx / dy at v-points [L2 ~> m2] real, intent(in) :: dt !< Tracer time step * I_numitts !! (I_numitts in tracer_hordiff) type(tracer_registry_type), pointer :: Reg !< Tracer registry type(lateral_boundary_diffusion_CS), intent(in) :: CS !< Control structure for this module ! Local variables - real, dimension(SZI_(G),SZJ_(G)) :: hbl !< bnd. layer depth [m] + real, dimension(SZI_(G),SZJ_(G)) :: hbl !< bnd. layer depth [H ~> m or kg m-2] real, dimension(SZI_(G),SZJ_(G),SZK_(G),CS%deg+1) :: ppoly0_coefs !< Coefficients of polynomial real, dimension(SZI_(G),SZJ_(G),SZK_(G),2) :: ppoly0_E !< Edge values from reconstructions real, dimension(SZK_(G),CS%deg+1) :: ppoly_S !< Slopes from reconstruction (placeholder) @@ -161,8 +161,9 @@ subroutine lateral_boundary_diffusion(G, GV, US, h, Coef_x, Coef_y, dt, Reg, CS) Idt = 1./dt hbl(:,:) = 0. - if (ASSOCIATED(CS%KPP_CSp)) call KPP_get_BLD(CS%KPP_CSp, hbl, G) - if (ASSOCIATED(CS%energetic_PBL_CSp)) call energetic_PBL_get_MLD(CS%energetic_PBL_CSp, hbl, G, US) + if (ASSOCIATED(CS%KPP_CSp)) call KPP_get_BLD(CS%KPP_CSp, hbl, G, US, m_to_BLD_units=GV%m_to_H) + if (ASSOCIATED(CS%energetic_PBL_CSp)) & + call energetic_PBL_get_MLD(CS%energetic_PBL_CSp, hbl, G, US, m_to_MLD_units=GV%m_to_H) call pass_var(hbl,G%Domain) do m = 1,Reg%ntr @@ -284,7 +285,7 @@ subroutine lateral_boundary_diffusion(G, GV, US, 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. + ! the tendency array and its units. if (tracer%id_lbdxy_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 ) @@ -302,8 +303,8 @@ real function bulk_average(boundary, nk, deg, h, hBLT, phi, ppoly0_E, ppoly0_coe integer :: boundary !< SURFACE or BOTTOM [nondim] integer :: nk !< Number of layers [nondim] integer :: deg !< Degree of polynomial [nondim] - real, dimension(nk) :: h !< Layer thicknesses [m] - real :: hBLT !< Depth of the boundary layer [m] + real, dimension(nk) :: h !< Layer thicknesses [H ~> m or kg m-2] + real :: hBLT !< Depth of the boundary layer [H ~> m or kg m-2] real, dimension(nk) :: phi !< Scalar quantity real, dimension(nk,2) :: ppoly0_E(:,:) !< Edge value of polynomial real, dimension(nk,deg+1) :: ppoly0_coefs(:,:) !< Coefficients of polynomial @@ -318,7 +319,7 @@ real function bulk_average(boundary, nk, deg, h, hBLT, phi, ppoly0_E, ppoly0_coe !! (0 if none, 1. if all). For the bottom boundary layer, this is always 1. !! because integration starts at the bottom [nondim] ! Local variables - real :: htot !< Running sum of the thicknesses (top to bottom) + real :: htot !< Running sum of the thicknesses (top to bottom) [H ~> m or kg m-2] integer :: k !< k indice @@ -364,8 +365,8 @@ end function harmonic_mean subroutine boundary_k_range(boundary, nk, h, hbl, k_top, zeta_top, k_bot, zeta_bot) integer, intent(in ) :: boundary !< SURFACE or BOTTOM [nondim] integer, intent(in ) :: nk !< Number of layers [nondim] - real, dimension(nk), intent(in ) :: h !< Layer thicknesses of the column [m] - real, intent(in ) :: hbl !< Thickness of the boundary layer [m] + real, dimension(nk), intent(in ) :: h !< Layer thicknesses of the column [H ~> m or kg m-2] + real, intent(in ) :: hbl !< Thickness of the boundary layer [H ~> m or kg m-2] !! If surface, with respect to zbl_ref = 0. !! If bottom, with respect to zbl_ref = SUM(h) integer, intent( out) :: k_top !< Index of the first layer within the boundary @@ -375,7 +376,7 @@ subroutine boundary_k_range(boundary, nk, h, hbl, k_top, zeta_top, k_bot, zeta_b real, intent( out) :: zeta_bot !< Distance of the lower layer to the boundary layer depth !! (0 at top, 1 at bottom) [nondim] ! Local variables - real :: htot + real :: htot ! Summed thickness [H ~> m or kg m-2] integer :: k ! Surface boundary layer if ( boundary == SURFACE ) then @@ -434,14 +435,14 @@ subroutine fluxes_layer_method(boundary, nk, deg, h_L, h_R, hbl_L, hbl_R, area_L integer, intent(in ) :: boundary !< Which boundary layer SURFACE or BOTTOM [nondim] integer, intent(in ) :: nk !< Number of layers [nondim] integer, intent(in ) :: deg !< order of the polynomial reconstruction [nondim] - real, dimension(nk), intent(in ) :: h_L !< Layer thickness (left) [m] - real, dimension(nk), intent(in ) :: h_R !< Layer thickness (right) [m] + real, dimension(nk), intent(in ) :: h_L !< Layer thickness (left) [H ~> m or kg m-2] + real, dimension(nk), intent(in ) :: h_R !< Layer thickness (right) [H ~> m or kg m-2] real, intent(in ) :: hbl_L !< Thickness of the boundary boundary - !! layer (left) [m] + !! layer (left) [H ~> m or kg m-2] real, intent(in ) :: hbl_R !< Thickness of the boundary boundary - !! layer (right) [m] - real, intent(in ) :: area_L !< Area of the horizontal grid (left) [m^2] - real, intent(in ) :: area_R !< Area of the horizontal grid (right) [m^2] + !! layer (right) [H ~> m or kg m-2] + real, intent(in ) :: area_L !< Area of the horizontal grid (left) [L2 ~> m2] + real, intent(in ) :: area_R !< Area of the horizontal grid (right) [L2 ~> m2] real, dimension(nk), intent(in ) :: phi_L !< Tracer values (left) [conc] real, dimension(nk), intent(in ) :: phi_R !< Tracer values (right) [conc] real, dimension(nk,deg+1), intent(in ) :: ppoly0_coefs_L !< Tracer reconstruction (left) [conc] @@ -449,19 +450,22 @@ subroutine fluxes_layer_method(boundary, nk, deg, h_L, h_R, hbl_L, hbl_R, area_L real, dimension(nk,2), intent(in ) :: ppoly0_E_L !< Polynomial edge values (left) [ nondim ] real, dimension(nk,2), intent(in ) :: ppoly0_E_R !< Polynomial edge values (right) [ nondim ] integer, intent(in ) :: method !< Method of polynomial integration [ nondim ] - real, intent(in ) :: khtr_u !< Horizontal diffusivities times delta t at U-point [m^2] - real, dimension(nk), intent( out) :: F_layer !< Layerwise diffusive flux at U- or V-point [m^3 conc] + real, intent(in ) :: khtr_u !< Horizontal diffusivities times delta t + !! at a velocity point [L2 ~> m2] + real, dimension(nk), intent( out) :: F_layer !< Layerwise diffusive flux at U- or V-point + !! [H L2 conc ~> m3 conc] ! Local variables - real, dimension(nk) :: h_means !< Calculate the layer-wise harmonic means [m] - real :: khtr_avg !< Thickness-weighted diffusivity at the u-point [m^2 s^-1] + real, dimension(nk) :: h_means !< Calculate the layer-wise harmonic means [H ~> m or kg m-2] + real :: khtr_avg !< Thickness-weighted diffusivity at the u-point [m^2 s^-1] !! This is just to remind developers that khtr_avg should be !! computed once khtr is 3D. - real :: heff !< Harmonic mean of layer thicknesses [m] - real :: inv_heff !< Inverse of the harmonic mean of layer thicknesses [m^[-1] + real :: heff !< Harmonic mean of layer thicknesses [H ~> m or kg m-2] + real :: inv_heff !< Inverse of the harmonic mean of layer thicknesses + !! [H-1 ~> m-1 or m2 kg-1] real :: phi_L_avg, phi_R_avg !< Bulk, thickness-weighted tracer averages (left and right column) - !! [conc m^-3 ] - real :: htot !< Total column thickness [m] + !! [conc m^-3 ] + real :: htot !< Total column thickness [H ~> m or kg m-2] integer :: k, k_bot_min, k_top_max !< k-indices, min and max for top and bottom, respectively integer :: k_top_L, k_bot_L !< k-indices left integer :: k_top_R, k_bot_R !< k-indices right @@ -547,14 +551,14 @@ subroutine fluxes_bulk_method(boundary, nk, deg, h_L, h_R, hbl_L, hbl_R, area_L, integer, intent(in ) :: boundary !< Which boundary layer SURFACE or BOTTOM [nondim] integer, intent(in ) :: nk !< Number of layers [nondim] integer, intent(in ) :: deg !< order of the polynomial reconstruction [nondim] - real, dimension(nk), intent(in ) :: h_L !< Layer thickness (left) [m] - real, dimension(nk), intent(in ) :: h_R !< Layer thickness (right) [m] + real, dimension(nk), intent(in ) :: h_L !< Layer thickness (left) [H ~> m or kg m-2] + real, dimension(nk), intent(in ) :: h_R !< Layer thickness (right) [H ~> m or kg m-2] real, intent(in ) :: hbl_L !< Thickness of the boundary boundary - !! layer (left) [m] + !! layer (left) [H ~> m or kg m-2] real, intent(in ) :: hbl_R !< Thickness of the boundary boundary - !! layer (left) [m] - real, intent(in ) :: area_L !< Area of the horizontal grid (left) [m^2] - real, intent(in ) :: area_R !< Area of the horizontal grid (right) [m^2] + !! layer (left) [H ~> m or kg m-2] + real, intent(in ) :: area_L !< Area of the horizontal grid (left) [L2 ~> m2] + real, intent(in ) :: area_R !< Area of the horizontal grid (right) [L2 ~> m2] real, dimension(nk), intent(in ) :: phi_L !< Tracer values (left) [conc] real, dimension(nk), intent(in ) :: phi_R !< Tracer values (right) [conc] real, dimension(nk,deg+1), intent(in ) :: ppoly0_coefs_L !< Tracer reconstruction (left) [conc] @@ -562,21 +566,25 @@ subroutine fluxes_bulk_method(boundary, nk, deg, h_L, h_R, hbl_L, hbl_R, area_L, real, dimension(nk,2), intent(in ) :: ppoly0_E_L !< Polynomial edge values (left) [nondim] real, dimension(nk,2), intent(in ) :: ppoly0_E_R !< Polynomial edge values (right) [nondim] integer, intent(in ) :: method !< Method of polynomial integration [nondim] - real, intent(in ) :: khtr_u !< Horizontal diffusivities times delta t at U-point [m^2] - real, intent( out) :: F_bulk !< The bulk mixed layer lateral flux [m^3 conc] - real, dimension(nk), intent( out) :: F_layer !< Layerwise diffusive flux at U-point [m^3 conc] + real, intent(in ) :: khtr_u !< Horizontal diffusivities times delta t + !! at a velocity point [L2 ~> m2] + real, intent( out) :: F_bulk !< The bulk mixed layer lateral flux + !! [H L2 conc ~> m3 conc] + real, dimension(nk), intent( out) :: F_layer !< Layerwise diffusive flux at U- or V-point + !! [H L2 conc ~> m3 conc] logical, optional, intent(in ) :: F_limit !< If True, apply a limiter ! Local variables - real, dimension(nk) :: h_means !< Calculate the layer-wise harmonic means [m] + real, dimension(nk) :: h_means !< Calculate the layer-wise harmonic means [H ~> m or kg m-2] real :: khtr_avg !< Thickness-weighted diffusivity at the u-point [m^2 s^-1] !! This is just to remind developers that khtr_avg should be !! computed once khtr is 3D. - real :: heff !< Harmonic mean of layer thicknesses [m] - real :: inv_heff !< Inverse of the harmonic mean of layer thicknesses [m^[-1] + real :: heff !< Harmonic mean of layer thicknesses [H ~> m or kg m-2] + real :: inv_heff !< Inverse of the harmonic mean of layer thicknesses + !! [H-1 ~> m-1 or m2 kg-1] real :: phi_L_avg, phi_R_avg !< Bulk, thickness-weighted tracer averages (left and right column) !! [conc m^-3 ] - real :: htot ! Total column thickness [m] + real :: htot !< Total column thickness [H ~> m or kg m-2] integer :: k, k_min, k_max !< k-indices, min and max for top and bottom, respectively integer :: k_top_L, k_bot_L !< k-indices left integer :: k_top_R, k_bot_R !< k-indices right @@ -728,7 +736,7 @@ logical function near_boundary_unit_tests( verbose ) real, dimension(nk,2) :: ppoly0_E_L, ppoly0_E_R! Polynomial edge values (left and right) [concentration] real, dimension(nk) :: h_L, h_R ! Layer thickness (left and right) [m] real :: khtr_u ! Horizontal diffusivities at U-point [m^2 s^-1] - real :: hbl_L, hbl_R ! Depth of the boundary layer (left and right) [m] + real :: hbl_L, hbl_R ! Depth of the boundary layer (left and right) [m] real :: F_bulk ! Total diffusive flux across the U point [nondim s^-1] real, dimension(nk) :: F_layer ! Diffusive flux within each layer at U-point [nondim s^-1] real :: h_u, hblt_u ! Thickness at the u-point [m] diff --git a/src/tracer/MOM_neutral_diffusion.F90 b/src/tracer/MOM_neutral_diffusion.F90 index 48678e1107..30cdec3b37 100644 --- a/src/tracer/MOM_neutral_diffusion.F90 +++ b/src/tracer/MOM_neutral_diffusion.F90 @@ -297,7 +297,7 @@ subroutine neutral_diffusion_calc_coeffs(G, GV, US, h, T, S, CS, p_surf) ! Variables used for reconstructions real, dimension(SZK_(G),2) :: ppoly_r_S ! Reconstruction slopes real, dimension(SZI_(G), SZJ_(G)) :: hEff_sum ! Summed effective face thicknesses [H ~> m or kg m-2] - real, dimension(SZI_(G),SZJ_(G)) :: hbl ! Boundary layer depth [m] + real, dimension(SZI_(G),SZJ_(G)) :: hbl ! Boundary layer depth [H ~> m or kg m-2] integer :: iMethod real, dimension(SZI_(G)) :: ref_pres ! Reference pressure used to calculate alpha/beta [R L2 T-2 ~> Pa] real, dimension(SZI_(G)) :: rho_tmp ! Routine to calculate drho_dp, returns density which is not used @@ -317,8 +317,9 @@ subroutine neutral_diffusion_calc_coeffs(G, GV, US, h, T, S, CS, p_surf) ! Check if hbl needs to be extracted if (CS%interior_only) then hbl(:,:) = 0. - if (ASSOCIATED(CS%KPP_CSp)) call KPP_get_BLD(CS%KPP_CSp, hbl, G) - if (ASSOCIATED(CS%energetic_PBL_CSp)) call energetic_PBL_get_MLD(CS%energetic_PBL_CSp, hbl, G, US) + if (ASSOCIATED(CS%KPP_CSp)) call KPP_get_BLD(CS%KPP_CSp, hbl, G, US, m_to_BLD_units=GV%m_to_H) + if (ASSOCIATED(CS%energetic_PBL_CSp)) & + call energetic_PBL_get_MLD(CS%energetic_PBL_CSp, hbl, G, US, m_to_MLD_units=GV%m_to_H) call pass_var(hbl, G%Domain) ! get k-indices and zeta do j=G%jsc-1, G%jec+1 ; do i=G%isc-1,G%iec+1 diff --git a/src/tracer/MOM_tracer_hor_diff.F90 b/src/tracer/MOM_tracer_hor_diff.F90 index cdbaaf28b9..02255d9424 100644 --- a/src/tracer/MOM_tracer_hor_diff.F90 +++ b/src/tracer/MOM_tracer_hor_diff.F90 @@ -141,14 +141,14 @@ subroutine tracer_hordiff(h, dt, MEKE, VarMix, G, GV, US, CS, Reg, tv, do_online real, dimension(SZIB_(G),SZJ_(G)) :: & khdt_x, & ! The value of Khtr*dt times the open face width divided by ! the distance between adjacent tracer points [L2 ~> m2]. - Coef_x, & ! The coefficients relating zonal tracer differences - ! to time-integrated fluxes [H L2 ~> m3 or kg]. + Coef_x, & ! The coefficients relating zonal tracer differences to time-integrated + ! fluxes, in [L2 ~> m2] for some schemes and [H L2 ~> m3 or kg] for others. Kh_u ! Tracer mixing coefficient at u-points [L2 T-1 ~> m2 s-1]. real, dimension(SZI_(G),SZJB_(G)) :: & khdt_y, & ! The value of Khtr*dt times the open face width divided by ! the distance between adjacent tracer points [L2 ~> m2]. - Coef_y, & ! The coefficients relating meridional tracer differences - ! to time-integrated fluxes [H L2 ~> m3 or kg]. + Coef_y, & ! The coefficients relating meridional tracer differences to time-integrated + ! fluxes, in [L2 ~> m2] for some schemes and [H L2 ~> m3 or kg] for others. Kh_v ! Tracer mixing coefficient at u-points [L2 T-1 ~> m2 s-1]. real :: khdt_max ! The local limiting value of khdt_x or khdt_y [L2 ~> m2]. From d820561d7425a21fe50c2ab6fd11edc09b46b771 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 30 Apr 2020 20:14:55 -0400 Subject: [PATCH 249/316] +Rescaled visc%MLD and Hml in diabatic to [Z] Rescaled the units to [Z] of the visc%MLD element of the vertvisc_type and the Hml argument to diabatic, which in turn is an argument to bulkmixedlayer, calculate_CVMix_conv, call_tracer_column_fns, MOM_generic_tracer_column_physics and mixedlayer_restrat and stored in the MOM_control_struct as CS%Hml. In addition when visc%MLD is read from a restart file, it is rescaled if the scaling has changed between run segments. All answers are bitwise identical. --- src/core/MOM.F90 | 18 ++++++++++--- src/core/MOM_variables.F90 | 2 +- .../lateral/MOM_mixed_layer_restrat.F90 | 10 +++---- .../vertical/MOM_CVMix_conv.F90 | 18 ++++++------- .../vertical/MOM_bulk_mixed_layer.F90 | 4 +-- .../vertical/MOM_diabatic_driver.F90 | 22 ++++++++-------- .../vertical/MOM_set_viscosity.F90 | 12 ++++++++- src/tracer/MOM_generic_tracer.F90 | 26 ++++++++++--------- src/tracer/MOM_offline_main.F90 | 2 +- src/tracer/MOM_tracer_flow_control.F90 | 2 +- 10 files changed, 69 insertions(+), 47 deletions(-) diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index 34266b51ab..e3bd314273 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -184,7 +184,7 @@ module MOM !< free surface height or column mass time averaged over the last !! baroclinic dynamics time step [H ~> m or kg m-2] real, dimension(:,:), pointer :: & - Hml => NULL() !< active mixed layer depth [m] + Hml => NULL() !< active mixed layer depth [Z ~> 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 [T ~> s]. @@ -2701,6 +2701,18 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & endif endif + if (use_ice_shelf .and. associated(CS%Hml)) then + if (query_initialized(CS%Hml, "hML", restart_CSp)) then + ! Test whether the dimensional rescaling has changed for depths. + if ((US%m_to_Z_restart /= 0.0) .and. (US%m_to_Z /= US%m_to_Z_restart) ) then + Z_rescale = US%m_to_Z / US%m_to_Z_restart + do j=js,je ; do i=is,ie + CS%Hml(i,j) = Z_rescale * CS%Hml(i,j) + enddo ; enddo + endif + endif + endif + if (.not.query_initialized(CS%ave_ssh_ibc,"ave_ssh",restart_CSp)) then if (CS%split) then call find_eta(CS%h, CS%tv, G, GV, US, CS%ave_ssh_ibc, eta, eta_to_m=1.0) @@ -3047,7 +3059,7 @@ subroutine extract_surface_state(CS, sfc_state_in) ! copy Hml into sfc_state, so that caps can access it if (associated(CS%Hml)) then do j=js,je ; do i=is,ie - sfc_state%Hml(i,j) = US%m_to_Z*CS%Hml(i,j) + sfc_state%Hml(i,j) = CS%Hml(i,j) enddo ; enddo endif @@ -3205,7 +3217,7 @@ subroutine extract_surface_state(CS, sfc_state_in) enddo do k=1,nz ; do i=is,ie - depth_ml = min(CS%HFrz, CS%visc%MLD(i,j)) + depth_ml = min(CS%HFrz, US%Z_to_m*CS%visc%MLD(i,j)) if (depth(i) + h(i,j,k)*GV%H_to_m < depth_ml) then dh = h(i,j,k)*GV%H_to_m elseif (depth(i) < depth_ml) then diff --git a/src/core/MOM_variables.F90 b/src/core/MOM_variables.F90 index b74e90ff5e..a8a367a7fe 100644 --- a/src/core/MOM_variables.F90 +++ b/src/core/MOM_variables.F90 @@ -229,7 +229,7 @@ module MOM_variables real, pointer, dimension(:,:) :: nkml_visc_v => NULL() !< The number of layers in the viscous surface mixed layer at v-points [nondim]. real, pointer, dimension(:,:) :: & - MLD => NULL() !< Instantaneous active mixing layer depth in unscaled MKS units [m]. + MLD => NULL() !< Instantaneous active mixing layer depth [Z ~> m]. real, pointer, dimension(:,:,:) :: & Ray_u => NULL(), & !< The Rayleigh drag velocity to be applied to each layer at u-points [Z T-1 ~> m s-1]. Ray_v => NULL() !< The Rayleigh drag velocity to be applied to each layer at v-points [Z T-1 ~> m s-1]. diff --git a/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 b/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 index c1b608b16b..3a3a25429c 100644 --- a/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 +++ b/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 @@ -101,7 +101,7 @@ subroutine mixedlayer_restrat(h, uhtr, vhtr, tv, forces, dt, MLD, VarMix, G, GV, type(mech_forcing), intent(in) :: forces !< A structure with the driving mechanical forces real, intent(in) :: dt !< Time increment [T ~> s] real, dimension(:,:), pointer :: MLD !< Mixed layer depth provided by the - !! PBL scheme [H ~> m or kg m-2] + !! PBL scheme [Z ~> m] type(VarMix_CS), pointer :: VarMix !< Container for derived fields type(mixedlayer_restrat_CS), pointer :: CS !< Module control structure @@ -131,7 +131,7 @@ subroutine mixedlayer_restrat_general(h, uhtr, vhtr, tv, forces, dt, MLD_in, Var type(mech_forcing), intent(in) :: forces !< A structure with the driving mechanical forces real, intent(in) :: dt !< Time increment [T ~> s] real, dimension(:,:), pointer :: MLD_in !< Mixed layer depth provided by the - !! PBL scheme [m] (not H) + !! PBL scheme [Z ~> m] (not H) type(VarMix_CS), pointer :: VarMix !< Container for derived fields type(mixedlayer_restrat_CS), pointer :: CS !< Module control structure ! Local variables @@ -240,7 +240,7 @@ subroutine mixedlayer_restrat_general(h, uhtr, vhtr, tv, forces, dt, MLD_in, Var if (.not. associated(MLD_in)) call MOM_error(FATAL, "MOM_mixedlayer_restrat: "// & "Argument MLD_in was not associated!") do j = js-1, je+1 ; do i = is-1, ie+1 - MLD_fast(i,j) = (CS%MLE_MLD_stretch * GV%m_to_H) * MLD_in(i,j) + MLD_fast(i,j) = (CS%MLE_MLD_stretch * GV%Z_to_H) * MLD_in(i,j) enddo ; enddo else call MOM_error(FATAL, "MOM_mixedlayer_restrat: "// & @@ -250,8 +250,8 @@ subroutine mixedlayer_restrat_general(h, uhtr, vhtr, tv, forces, dt, MLD_in, Var ! Apply time filter (to remove diurnal cycle) if (CS%MLE_MLD_decay_time>0.) then if (CS%debug) then - call hchksum(CS%MLD_filtered,'mixed_layer_restrat: MLD_filtered',G%HI,haloshift=1,scale=GV%H_to_m) - call hchksum(MLD_in,'mixed_layer_restrat: MLD in',G%HI,haloshift=1) + call hchksum(CS%MLD_filtered, 'mixed_layer_restrat: MLD_filtered', G%HI, haloshift=1, scale=GV%H_to_m) + call hchksum(MLD_in, 'mixed_layer_restrat: MLD in', G%HI, haloshift=1, scale=US%Z_to_m) endif aFac = CS%MLE_MLD_decay_time / ( dt + CS%MLE_MLD_decay_time ) bFac = dt / ( dt + CS%MLE_MLD_decay_time ) diff --git a/src/parameterizations/vertical/MOM_CVMix_conv.F90 b/src/parameterizations/vertical/MOM_CVMix_conv.F90 index 0b1abba577..06974095e1 100644 --- a/src/parameterizations/vertical/MOM_CVMix_conv.F90 +++ b/src/parameterizations/vertical/MOM_CVMix_conv.F90 @@ -154,9 +154,9 @@ subroutine calculate_CVMix_conv(h, tv, G, GV, US, CS, hbl) type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer thickness [H ~> m or kg m-2]. type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamics structure. - type(CVMix_conv_cs), pointer :: CS !< The control structure returned + type(CVMix_conv_cs), pointer :: CS !< The control structure returned !! by a previous call to CVMix_conv_init. - real, dimension(:,:), optional, pointer :: hbl!< Depth of ocean boundary layer [m] + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: hbl !< Depth of ocean boundary layer [Z ~> m] ! local variables real, dimension(SZK_(G)) :: rho_lwr !< Adiabatic Water Density, this is a dummy !! variable since here convection is always @@ -172,7 +172,9 @@ subroutine calculate_CVMix_conv(h, tv, G, GV, US, CS, hbl) ! [Z s-2 R-1 ~> m4 s-2 kg-1] real :: pref ! Interface pressures [R L2 T-2 ~> Pa] real :: rhok, rhokm1 ! In situ densities of the layers above and below at the interface pressure [R ~> kg m-3] - real :: dz, dh, hcorr + real :: hbl_KPP ! The depth of the ocean boundary as used by KPP [m] + real :: dz ! A thickness [Z ~> m] + real :: dh, hcorr ! Two thicknesses [m] integer :: i, j, k g_o_rho0 = US%L_to_Z**2*US%s_to_T**2 * GV%g_Earth / GV%Rho0 @@ -180,11 +182,6 @@ subroutine calculate_CVMix_conv(h, tv, G, GV, US, CS, hbl) ! initialize dummy variables rho_lwr(:) = 0.0; rho_1d(:) = 0.0 - if (.not. associated(hbl)) then - allocate(hbl(SZI_(G), SZJ_(G))) - hbl(:,:) = 0.0 - endif - do j = G%jsc, G%jec do i = G%isc, G%iec @@ -213,7 +210,7 @@ subroutine calculate_CVMix_conv(h, tv, G, GV, US, CS, hbl) 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 = h(i,j,k) * GV%H_to_m ! Nominal thickness to use for increment, in the units used by CVMix. 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 @@ -222,7 +219,8 @@ subroutine calculate_CVMix_conv(h, tv, G, GV, US, CS, hbl) enddo ! gets index of the level and interface above hbl - kOBL = CVMix_kpp_compute_kOBL_depth(iFaceHeight, cellHeight,hbl(i,j)) + hbl_KPP = US%Z_to_m*hbl(i,j) ! Convert to the units used by CVMix. + kOBL = CVMix_kpp_compute_kOBL_depth(iFaceHeight, cellHeight, hbl_KPP) kv_col(:) = 0.0 ; kd_col(:) = 0.0 call CVMix_coeffs_conv(Mdiff_out=kv_col(:), & diff --git a/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 b/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 index 28b1b8cc0b..358c7a7fa7 100644 --- a/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 +++ b/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 @@ -219,7 +219,7 @@ subroutine bulkmixedlayer(h_3d, u_3d, v_3d, tv, fluxes, dt, ea, eb, G, GV, US, C type(optics_type), pointer :: optics !< The structure containing the inverse of the !! vertical absorption decay scale for !! penetrating shortwave radiation [m-1]. - real, dimension(:,:), pointer :: Hml !< Active mixed layer depth [m]. + real, dimension(:,:), pointer :: Hml !< Active mixed layer depth [Z ~> m]. logical, intent(in) :: aggregate_FW_forcing !< If true, the net incoming and !! outgoing surface freshwater fluxes are !! combined before being applied, instead of @@ -592,7 +592,7 @@ subroutine bulkmixedlayer(h_3d, u_3d, v_3d, tv, fluxes, dt, ea, eb, G, GV, US, C CS%ML_depth(i,j) = h(i,0) * GV%H_to_m ! Rescale the diagnostic. enddo ; endif if (associated(Hml)) then ; do i=is,ie - Hml(i,j) = G%mask2dT(i,j) * (h(i,0) * GV%H_to_m) ! Rescale the diagnostic for output. + Hml(i,j) = G%mask2dT(i,j) * (h(i,0) * GV%H_to_Z) ! Rescale the diagnostic for output. enddo ; endif ! At this point, return water to the original layers, but constrained to diff --git a/src/parameterizations/vertical/MOM_diabatic_driver.F90 b/src/parameterizations/vertical/MOM_diabatic_driver.F90 index 3c017c0f6c..d753afc97b 100644 --- a/src/parameterizations/vertical/MOM_diabatic_driver.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_driver.F90 @@ -263,7 +263,7 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(inout) :: h !< thickness [H ~> m or kg m-2] type(thermo_var_ptrs), intent(inout) :: tv !< points to thermodynamic fields !! unused have NULL ptrs - real, dimension(:,:), pointer :: Hml !< Active mixed layer depth [m] + real, dimension(:,:), pointer :: Hml !< Active mixed layer depth [Z ~> m] 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 @@ -451,7 +451,7 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Tim real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(inout) :: h !< thickness [H ~> m or kg m-2] type(thermo_var_ptrs), intent(inout) :: tv !< points to thermodynamic fields !! unused have NULL ptrs - real, dimension(:,:), pointer :: Hml !< Active mixed layer depth [m] + real, dimension(:,:), pointer :: Hml !< Active mixed layer depth [Z ~> m] 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 @@ -663,7 +663,7 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Tim Kd_salt, visc%Kv_shear, CS%KPP_NLTheat, CS%KPP_NLTscalar, Waves=Waves) if (associated(Hml)) then - call KPP_get_BLD(CS%KPP_CSp, Hml(:,:), G, US, m_to_BLD_units=1.0) + call KPP_get_BLD(CS%KPP_CSp, Hml(:,:), G, US) call pass_var(Hml, G%domain, halo=1) ! If visc%MLD exists, copy KPP's BLD into it if (associated(visc%MLD)) visc%MLD(:,:) = Hml(:,:) @@ -840,12 +840,12 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Tim CS%energetic_PBL_CSp, dSV_dT, dSV_dS, cTKE, SkinBuoyFlux, waves=waves) if (associated(Hml)) then - call energetic_PBL_get_MLD(CS%energetic_PBL_CSp, Hml(:,:), G, US, m_to_MLD_units=1.0) + call energetic_PBL_get_MLD(CS%energetic_PBL_CSp, Hml(:,:), G, US) call pass_var(Hml, G%domain, halo=1) ! If visc%MLD exists, copy ePBL's MLD into it if (associated(visc%MLD)) visc%MLD(:,:) = Hml(:,:) elseif (associated(visc%MLD)) then - call energetic_PBL_get_MLD(CS%energetic_PBL_CSp, visc%MLD, G, US, m_to_MLD_units=1.0) + call energetic_PBL_get_MLD(CS%energetic_PBL_CSp, visc%MLD, G, US) call pass_var(visc%MLD, G%domain, halo=1) endif @@ -1232,7 +1232,7 @@ subroutine diabatic_ALE(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(inout) :: h !< thickness [H ~> m or kg m-2] type(thermo_var_ptrs), intent(inout) :: tv !< points to thermodynamic fields !! unused have NULL ptrs - real, dimension(:,:), pointer :: Hml !< Active mixed layer depth [m] + real, dimension(:,:), pointer :: Hml !< Active mixed layer depth [Z ~> m] 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 @@ -1446,7 +1446,7 @@ subroutine diabatic_ALE(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, Kd_salt, visc%Kv_shear, CS%KPP_NLTheat, CS%KPP_NLTscalar, Waves=Waves) if (associated(Hml)) then - call KPP_get_BLD(CS%KPP_CSp, Hml(:,:), G, US, m_to_BLD_units=1.0) + call KPP_get_BLD(CS%KPP_CSp, Hml(:,:), G, US) call pass_var(Hml, G%domain, halo=1) ! If visc%MLD exists, copy KPP's BLD into it if (associated(visc%MLD)) visc%MLD(:,:) = Hml(:,:) @@ -1569,12 +1569,12 @@ subroutine diabatic_ALE(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, CS%energetic_PBL_CSp, dSV_dT, dSV_dS, cTKE, SkinBuoyFlux, waves=waves) if (associated(Hml)) then - call energetic_PBL_get_MLD(CS%energetic_PBL_CSp, Hml(:,:), G, US, m_to_MLD_units=1.0) + call energetic_PBL_get_MLD(CS%energetic_PBL_CSp, Hml(:,:), G, US) call pass_var(Hml, G%domain, halo=1) ! If visc%MLD exists, copy ePBL's MLD into it if (associated(visc%MLD)) visc%MLD(:,:) = Hml(:,:) elseif (associated(visc%MLD)) then - call energetic_PBL_get_MLD(CS%energetic_PBL_CSp, visc%MLD, G, US, m_to_MLD_units=1.0) + call energetic_PBL_get_MLD(CS%energetic_PBL_CSp, visc%MLD, G, US) call pass_var(visc%MLD, G%domain, halo=1) endif @@ -1910,7 +1910,7 @@ subroutine layered_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_e real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(inout) :: h !< thickness [H ~> m or kg m-2] type(thermo_var_ptrs), intent(inout) :: tv !< points to thermodynamic fields !! unused have NULL ptrs - real, dimension(:,:), pointer :: Hml !< Active mixed layer depth [m] + real, dimension(:,:), pointer :: Hml !< Active mixed layer depth [Z ~> m] 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 @@ -2179,7 +2179,7 @@ subroutine layered_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_e Kd_salt, visc%Kv_shear, CS%KPP_NLTheat, CS%KPP_NLTscalar, Waves=Waves) if (associated(Hml)) then - call KPP_get_BLD(CS%KPP_CSp, Hml(:,:), G, US, m_to_BLD_units=1.0) + call KPP_get_BLD(CS%KPP_CSp, Hml(:,:), G, US) call pass_var(Hml, G%domain, halo=1) ! If visc%MLD exists, copy KPP's BLD into it if (associated(visc%MLD)) visc%MLD(:,:) = Hml(:,:) diff --git a/src/parameterizations/vertical/MOM_set_viscosity.F90 b/src/parameterizations/vertical/MOM_set_viscosity.F90 index 0046cd8b18..f208b9fe09 100644 --- a/src/parameterizations/vertical/MOM_set_viscosity.F90 +++ b/src/parameterizations/vertical/MOM_set_viscosity.F90 @@ -1844,7 +1844,7 @@ subroutine set_visc_init(Time, G, GV, US, param_file, diag, visc, CS, restart_CS integer :: i, j, k, is, ie, js, je, n integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB, nz logical :: default_2018_answers - logical :: use_kappa_shear, adiabatic, use_omega + logical :: use_kappa_shear, adiabatic, use_omega, MLE_use_PBL_MLD logical :: use_CVMix_ddiff, differential_diffusion, use_KPP character(len=200) :: filename, tideamp_file type(OBC_segment_type), pointer :: segment => NULL() ! pointer to OBC segment type @@ -2047,6 +2047,9 @@ subroutine set_visc_init(Time, G, GV, US, param_file, diag, visc, CS, restart_CS if (CS%c_Smag < 0.0) CS%c_Smag = 0.15 endif + call get_param(param_file, mdl, "MLE_USE_PBL_MLD", MLE_use_PBL_MLD, & + default=.false., do_not_log=.true.) + if (CS%RiNo_mix .and. kappa_shear_at_vertex(param_file)) then ! This is necessary for reproduciblity across restarts in non-symmetric mode. call pass_var(visc%Kv_shear_Bu, G%Domain, position=CORNER, complete=.true.) @@ -2140,7 +2143,14 @@ subroutine set_visc_init(Time, G, GV, US, param_file, diag, visc, CS, restart_CS visc%Kv_shear_Bu(I,J,k) = Z2_T_rescale * visc%Kv_shear_Bu(I,J,k) enddo ; enddo ; enddo endif ; endif + endif + if (MLE_use_PBL_MLD .and. (Z_rescale /= 1.0)) then + if (associated(visc%MLD)) then ; if (query_initialized(visc%MLD, "MLD", restart_CS)) then + do j=js,je ; do i=is,ie + visc%MLD(i,j) = Z_rescale * visc%MLD(i,j) + enddo ; enddo + endif ; endif endif end subroutine set_visc_init diff --git a/src/tracer/MOM_generic_tracer.F90 b/src/tracer/MOM_generic_tracer.F90 index e68833c3cd..b198db3e32 100644 --- a/src/tracer/MOM_generic_tracer.F90 +++ b/src/tracer/MOM_generic_tracer.F90 @@ -388,8 +388,8 @@ end subroutine initialize_MOM_generic_tracer !! flux as a source. subroutine MOM_generic_tracer_column_physics(h_old, h_new, ea, eb, fluxes, Hml, dt, G, GV, CS, tv, optics, & 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 [H ~> m or kg m-2]. real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & @@ -402,16 +402,16 @@ subroutine MOM_generic_tracer_column_physics(h_old, h_new, ea, eb, fluxes, Hml, !! below during this call [H ~> m or kg m-2]. type(forcing), intent(in) :: fluxes !< A structure containing pointers to thermodynamic !! and tracer forcing fields. - real, dimension(SZI_(G),SZJ_(G)), intent(in) :: Hml !< Mixed layer depth [H ~> m or kg m-2] - real, intent(in) :: dt !< The amount of time covered by this call [s] + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: Hml !< Mixed layer depth [Z ~> m] + real, intent(in) :: dt !< The amount of time covered by this call [s] type(MOM_generic_tracer_CS), pointer :: CS !< Pointer to the control structure for this module. - type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various thermodynamic variables + type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various thermodynamic variables type(optics_type), intent(in) :: optics !< The structure containing optical properties. 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 [H ~> m or kg m-2] - ! Stored previously in diabatic CS. + !! can be applied [H ~> m or kg m-2] + ! 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) @@ -423,6 +423,7 @@ subroutine MOM_generic_tracer_column_physics(h_old, h_new, ea, eb, fluxes, Hml, real, dimension(:,:), pointer :: stf_array,trunoff_array,runoff_tracer_flux_array real :: surface_field(SZI_(G),SZJ_(G)) + real :: dz_ml(SZI_(G),SZJ_(G)) ! The mixed layer depth in the MKS units used for generic tracers [m] real :: sosga real, dimension(G%isd:G%ied,G%jsd:G%jed,G%ke) :: rho_dzt, dzt @@ -483,9 +484,10 @@ subroutine MOM_generic_tracer_column_physics(h_old, h_new, ea, eb, fluxes, Hml, 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 !} - + dz_ml(:,:) = 0.0 do j=jsc,jec ; do i=isc,iec - surface_field(i,j) = tv%S(i,j,1) + surface_field(i,j) = tv%S(i,j,1) + dz_ml(i,j) = G%US%Z_to_m * Hml enddo ; enddo sosga = global_area_mean(surface_field, G) @@ -494,12 +496,12 @@ subroutine MOM_generic_tracer_column_physics(h_old, h_new, ea, eb, fluxes, Hml, ! if ((G%US%L_to_m == 1.0) .and. (G%US%RZ_to_kg_m2 == 1.0) .and. (G%US%s_to_T == 1.0)) then ! Avoid unnecessary copies when no unit conversion is needed. - call generic_tracer_source(tv%T, tv%S, rho_dzt, dzt, Hml, G%isd, G%jsd, 1, dt, & + call generic_tracer_source(tv%T, tv%S, rho_dzt, dzt, dz_ml, G%isd, G%jsd, 1, dt, & G%areaT, get_diag_time_end(CS%diag), & optics%nbands, optics%max_wavelength_band, optics%sw_pen_band, optics%opacity_band, & internal_heat=tv%internal_heat, frunoff=fluxes%frunoff, sosga=sosga) else - call generic_tracer_source(tv%T, tv%S, rho_dzt, dzt, Hml, G%isd, G%jsd, 1, dt, & + call generic_tracer_source(tv%T, tv%S, rho_dzt, dzt, dz_ml, G%isd, G%jsd, 1, dt, & G%US%L_to_m**2*G%areaT(:,:), get_diag_time_end(CS%diag), & optics%nbands, optics%max_wavelength_band, optics%sw_pen_band, optics%opacity_band, & internal_heat=G%US%RZ_to_kg_m2*tv%internal_heat(:,:), & diff --git a/src/tracer/MOM_offline_main.F90 b/src/tracer/MOM_offline_main.F90 index dfdcb4c09b..65f83ecfea 100644 --- a/src/tracer/MOM_offline_main.F90 +++ b/src/tracer/MOM_offline_main.F90 @@ -176,7 +176,7 @@ module MOM_offline_main real, allocatable, dimension(:,:) :: netMassIn !< Freshwater fluxes into the ocean real, allocatable, dimension(:,:) :: netMassOut !< Freshwater fluxes out of the ocean - real, allocatable, dimension(:,:) :: mld !< Mixed layer depths at thickness points [H ~> m or kg m-2]. + real, allocatable, dimension(:,:) :: mld !< Mixed layer depths at thickness points [Z ~> m]. ! Allocatable arrays to read in entire fields during initialization real, allocatable, dimension(:,:,:,:) :: uhtr_all !< Entire field of zonal transport diff --git a/src/tracer/MOM_tracer_flow_control.F90 b/src/tracer/MOM_tracer_flow_control.F90 index 86003605f7..a9bf9a03d9 100644 --- a/src/tracer/MOM_tracer_flow_control.F90 +++ b/src/tracer/MOM_tracer_flow_control.F90 @@ -417,7 +417,7 @@ subroutine call_tracer_column_fns(h_old, h_new, ea, eb, fluxes, Hml, dt, G, GV, type(forcing), intent(in) :: fluxes !< A structure containing pointers to !! any possible forcing fields. !! Unused fields have NULL ptrs. - real, dimension(NIMEM_,NJMEM_), intent(in) :: Hml !< Mixed layer depth [H ~> m or kg m-2] + real, dimension(NIMEM_,NJMEM_), intent(in) :: Hml !< Mixed layer depth [Z ~> m] real, intent(in) :: dt !< The amount of time covered by this !! call [T ~> s] type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. From bee6be783bbc996eec72016615f4079221f5a208 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 1 May 2020 10:20:42 -0400 Subject: [PATCH 250/316] +Rescaled sfc_state%frazil and other variables Rescaled the sea_lev, frazil, melt_potential, taux_shelf, tauy_shelf, TempxPmE, salt_deficit, ocean_mass, ocean_heat, ocean_salt and internal_heat elements of the surface state type. This change includes the addition of a unit_scale_type argument to MOM_surface_chksum. Several related internal variables were rescaled as well or otherwise made less idiosyncratic, notably in extract_surface_state, MOM_forcing_chksum, forcing_diagnostics. All solutions are bitwise identical, but there are changes to the units of transparent types and a new argument to a publicly visible subroutine. --- config_src/coupled_driver/ocean_model_MOM.F90 | 10 +-- config_src/mct_driver/mom_ocean_model_mct.F90 | 14 ++-- .../nuopc_driver/mom_ocean_model_nuopc.F90 | 14 ++-- src/core/MOM.F90 | 82 +++++++++--------- src/core/MOM_PressureForce_analytic_FV.F90 | 2 +- src/core/MOM_checksum_packages.F90 | 17 ++-- src/core/MOM_forcing_type.F90 | 84 +++++++++---------- src/core/MOM_variables.F90 | 24 +++--- src/ice_shelf/MOM_ice_shelf.F90 | 36 ++++---- src/ice_shelf/MOM_marine_ice.F90 | 21 +++-- 10 files changed, 148 insertions(+), 156 deletions(-) diff --git a/config_src/coupled_driver/ocean_model_MOM.F90 b/config_src/coupled_driver/ocean_model_MOM.F90 index 28ac193d8d..05759cb7b8 100644 --- a/config_src/coupled_driver/ocean_model_MOM.F90 +++ b/config_src/coupled_driver/ocean_model_MOM.F90 @@ -862,19 +862,19 @@ subroutine convert_state_to_ocean_type(sfc_state, Ocean_sfc, G, US, patm, press_ if (present(patm)) then do j=jsc_bnd,jec_bnd ; do i=isc_bnd,iec_bnd - Ocean_sfc%sea_lev(i,j) = sfc_state%sea_lev(i+i0,j+j0) + patm(i,j) * press_to_z - Ocean_sfc%area(i,j) = US%L_to_m**2*G%areaT(i+i0,j+j0) + Ocean_sfc%sea_lev(i,j) = US%Z_to_m * sfc_state%sea_lev(i+i0,j+j0) + patm(i,j) * press_to_z + Ocean_sfc%area(i,j) = US%L_to_m**2 * G%areaT(i+i0,j+j0) enddo ; enddo else do j=jsc_bnd,jec_bnd ; do i=isc_bnd,iec_bnd - Ocean_sfc%sea_lev(i,j) = sfc_state%sea_lev(i+i0,j+j0) - Ocean_sfc%area(i,j) = US%L_to_m**2*G%areaT(i+i0,j+j0) + Ocean_sfc%sea_lev(i,j) = US%Z_to_m * sfc_state%sea_lev(i+i0,j+j0) + Ocean_sfc%area(i,j) = US%L_to_m**2 * G%areaT(i+i0,j+j0) enddo ; enddo endif if (allocated(sfc_state%frazil)) then do j=jsc_bnd,jec_bnd ; do i=isc_bnd,iec_bnd - Ocean_sfc%frazil(i,j) = sfc_state%frazil(i+i0,j+j0) + Ocean_sfc%frazil(i,j) = US%Q_to_J_kg*US%RZ_to_kg_m2 * sfc_state%frazil(i+i0,j+j0) enddo ; enddo endif diff --git a/config_src/mct_driver/mom_ocean_model_mct.F90 b/config_src/mct_driver/mom_ocean_model_mct.F90 index 1d1e9fa888..f8a4a19532 100644 --- a/config_src/mct_driver/mom_ocean_model_mct.F90 +++ b/config_src/mct_driver/mom_ocean_model_mct.F90 @@ -894,31 +894,31 @@ subroutine convert_state_to_ocean_type(sfc_state, Ocean_sfc, G, US, patm, press_ if (present(patm)) then do j=jsc_bnd,jec_bnd ; do i=isc_bnd,iec_bnd - Ocean_sfc%sea_lev(i,j) = sfc_state%sea_lev(i+i0,j+j0) + patm(i,j) * press_to_z - Ocean_sfc%area(i,j) = US%L_to_m**2*G%areaT(i+i0,j+j0) + Ocean_sfc%sea_lev(i,j) = US%Z_to_m * sfc_state%sea_lev(i+i0,j+j0) + patm(i,j) * press_to_z + Ocean_sfc%area(i,j) = US%L_to_m**2 * G%areaT(i+i0,j+j0) enddo ; enddo else do j=jsc_bnd,jec_bnd ; do i=isc_bnd,iec_bnd - Ocean_sfc%sea_lev(i,j) = sfc_state%sea_lev(i+i0,j+j0) - Ocean_sfc%area(i,j) = US%L_to_m**2*G%areaT(i+i0,j+j0) + Ocean_sfc%sea_lev(i,j) = US%Z_to_m * sfc_state%sea_lev(i+i0,j+j0) + Ocean_sfc%area(i,j) = US%L_to_m**2 * G%areaT(i+i0,j+j0) enddo ; enddo endif if (allocated(sfc_state%frazil)) then do j=jsc_bnd,jec_bnd ; do i=isc_bnd,iec_bnd - Ocean_sfc%frazil(i,j) = sfc_state%frazil(i+i0,j+j0) + Ocean_sfc%frazil(i,j) = US%Q_to_J_kg*US%RZ_to_kg_m2 * sfc_state%frazil(i+i0,j+j0) enddo ; enddo endif if (allocated(sfc_state%melt_potential)) then do j=jsc_bnd,jec_bnd ; do i=isc_bnd,iec_bnd - Ocean_sfc%melt_potential(i,j) = sfc_state%melt_potential(i+i0,j+j0) + Ocean_sfc%melt_potential(i,j) = US%Q_to_J_kg*US%RZ_to_kg_m2 * sfc_state%melt_potential(i+i0,j+j0) enddo ; enddo endif if (allocated(sfc_state%Hml)) then do j=jsc_bnd,jec_bnd ; do i=isc_bnd,iec_bnd - Ocean_sfc%OBLD(i,j) = US%Z_to_m*sfc_state%Hml(i+i0,j+j0) + Ocean_sfc%OBLD(i,j) = US%Z_to_m * sfc_state%Hml(i+i0,j+j0) enddo ; enddo endif diff --git a/config_src/nuopc_driver/mom_ocean_model_nuopc.F90 b/config_src/nuopc_driver/mom_ocean_model_nuopc.F90 index 22a4c7eaa2..9946aec4f9 100644 --- a/config_src/nuopc_driver/mom_ocean_model_nuopc.F90 +++ b/config_src/nuopc_driver/mom_ocean_model_nuopc.F90 @@ -889,31 +889,31 @@ subroutine convert_state_to_ocean_type(sfc_state, Ocean_sfc, G, US, patm, press_ if (present(patm)) then do j=jsc_bnd,jec_bnd ; do i=isc_bnd,iec_bnd - Ocean_sfc%sea_lev(i,j) = sfc_state%sea_lev(i+i0,j+j0) + patm(i,j) * press_to_z - Ocean_sfc%area(i,j) = US%L_to_m**2*G%areaT(i+i0,j+j0) + Ocean_sfc%sea_lev(i,j) = US%Z_to_m * sfc_state%sea_lev(i+i0,j+j0) + patm(i,j) * press_to_z + Ocean_sfc%area(i,j) = US%L_to_m**2 * G%areaT(i+i0,j+j0) enddo ; enddo else do j=jsc_bnd,jec_bnd ; do i=isc_bnd,iec_bnd - Ocean_sfc%sea_lev(i,j) = sfc_state%sea_lev(i+i0,j+j0) - Ocean_sfc%area(i,j) = US%L_to_m**2*G%areaT(i+i0,j+j0) + Ocean_sfc%sea_lev(i,j) = US%Z_to_m * sfc_state%sea_lev(i+i0,j+j0) + Ocean_sfc%area(i,j) = US%L_to_m**2 * G%areaT(i+i0,j+j0) enddo ; enddo endif if (allocated(sfc_state%frazil)) then do j=jsc_bnd,jec_bnd ; do i=isc_bnd,iec_bnd - Ocean_sfc%frazil(i,j) = sfc_state%frazil(i+i0,j+j0) + Ocean_sfc%frazil(i,j) = US%Q_to_J_kg*US%RZ_to_kg_m2 * sfc_state%frazil(i+i0,j+j0) enddo ; enddo endif if (allocated(sfc_state%melt_potential)) then do j=jsc_bnd,jec_bnd ; do i=isc_bnd,iec_bnd - Ocean_sfc%melt_potential(i,j) = sfc_state%melt_potential(i+i0,j+j0) + Ocean_sfc%melt_potential(i,j) = US%Q_to_J_kg*US%RZ_to_kg_m2 * sfc_state%melt_potential(i+i0,j+j0) enddo ; enddo endif if (allocated(sfc_state%Hml)) then do j=jsc_bnd,jec_bnd ; do i=isc_bnd,iec_bnd - Ocean_sfc%OBLD(i,j) = US%Z_to_m*sfc_state%Hml(i+i0,j+j0) + Ocean_sfc%OBLD(i,j) = US%Z_to_m * sfc_state%Hml(i+i0,j+j0) enddo ; enddo endif diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index e3bd314273..aff4860a21 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -296,20 +296,20 @@ module MOM !! average surface tracer properties when a bulk !! mixed layer is not used [Z ~> m], or a negative value !! if a bulk mixed layer is being used. - real :: HFrz !< If HFrz > 0, melt potential will be computed. - !! The actual depth over which melt potential is computed will - !! min(HFrz, OBLD), where OBLD is the boundary layer depth. + real :: HFrz !< If HFrz > 0, the nominal depth over which melt potential is + !! computed [Z ~> m]. The actual depth over which melt potential is + !! computed is min(HFrz, OBLD), where OBLD is the boundary layer depth. !! If HFrz <= 0 (default), melt potential will not be computed. real :: Hmix_UV !< Depth scale over which to average surface flow to !! feedback to the coupler/driver [Z ~> 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 [m] + real :: bad_val_ssh_max !< Maximum SSH before triggering bad value message [Z ~> m] real :: bad_val_sst_max !< Maximum SST before triggering bad value message [degC] real :: bad_val_sst_min !< Minimum SST before triggering bad value message [degC] real :: bad_val_sss_max !< Maximum SSS before triggering bad value message [ppt] - real :: bad_val_col_thick !< Minimum column thickness before triggering bad value message [m] + real :: bad_val_col_thick !< Minimum column thickness before triggering bad value message [Z ~> m] logical :: answers_2018 !< If true, use expressions for the surface properties that recover !! the answers from the end of 2018. Otherwise, use more appropriate !! expressions that differ at roundoff for non-Boussinsq cases. @@ -1859,7 +1859,7 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & "If HFREEZE > 0, melt potential will be computed. The actual depth "//& "over which melt potential is computed will be min(HFREEZE, OBLD), "//& "where OBLD is the boundary layer depth. If HFREEZE <= 0 (default), "//& - "melt potential will not be computed.", units="m", default=-1.0) + "melt potential will not be computed.", units="m", default=-1.0, scale=US%m_to_Z) call get_param(param_file, "MOM", "INTERPOLATE_P_SURF", CS%interp_p_surf, & "If true, linearly interpolate the surface pressure "//& "over the coupling time step, using the specified value "//& @@ -1944,8 +1944,8 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & 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 "//& - "triggered, if CHECK_BAD_SURFACE_VALS is true.", units="m", & - default=20.0) + "triggered, if CHECK_BAD_SURFACE_VALS is true.", & + units="m", default=20.0, scale=US%m_to_Z) call get_param(param_file, "MOM", "BAD_VAL_SSS_MAX", CS%bad_val_sss_max, & "The value of SSS above which a bad value message is "//& "triggered, if CHECK_BAD_SURFACE_VALS is true.", units="PPT", & @@ -1960,8 +1960,8 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & units="deg C", default=-2.1) call get_param(param_file, "MOM", "BAD_VAL_COLUMN_THICKNESS", CS%bad_val_col_thick, & "The value of column thickness below which a bad value message is "//& - "triggered, if CHECK_BAD_SURFACE_VALS is true.", units="m", & - default=0.0) + "triggered, if CHECK_BAD_SURFACE_VALS is true.", & + units="m", default=0.0, scale=US%m_to_Z) endif call get_param(param_file, "MOM", "DEFAULT_2018_ANSWERS", default_2018_answers, & "This sets the default value for the various _2018_ANSWERS parameters.", & @@ -3000,15 +3000,14 @@ subroutine extract_surface_state(CS, sfc_state_in) real :: depth_ml !< Depth over which to average to determine mixed !! layer properties [Z ~> m] or [H ~> m or kg m-2] real :: dh !< Thickness of a layer within the mixed layer [Z ~> m] or [H ~> m or kg m-2] - real :: mass !< Mass per unit area of a layer [kg m-2] - real :: bathy_m !< The depth of bathymetry [m] (not Z), used for error checking. + real :: mass !< Mass per unit area of a layer [R Z ~> kg m-2] real :: T_freeze !< freezing temperature [degC] real :: I_depth !< The inverse of depth [Z-1 ~> m-1] or [H-1 ~> m-1 or m2 kg-1] real :: missing_depth !< The portion of depth_ml that can not be found in a column [H ~> m or kg m-2] real :: H_rescale !< A conversion factor from thickness units to the units used in the !! calculation of properties of the uppermost ocean [nondim] or [Z H-1 ~> 1 or m3 kg-1] ! After the ANSWERS_2018 flag has been obsoleted, H_rescale will be 1. - real :: delT(SZI_(CS%G)) !< Depth integral of T-T_freeze [m degC] + real :: delT(SZI_(CS%G)) !< Depth integral of T-T_freeze [Z degC ~> m degC] logical :: use_temperature !< If true, temp and saln used as state variables. integer :: i, j, k, is, ie, js, je, nz, numberOfErrors, ig, jg integer :: isd, ied, jsd, jed @@ -3049,11 +3048,11 @@ subroutine extract_surface_state(CS, sfc_state_in) sfc_state%S_is_absS = CS%tv%S_is_absS do j=js,je ; do i=is,ie - sfc_state%sea_lev(i,j) = CS%ave_ssh_ibc(i,j) + sfc_state%sea_lev(i,j) = US%m_to_Z*CS%ave_ssh_ibc(i,j) enddo ; enddo if (allocated(sfc_state%frazil) .and. associated(CS%tv%frazil)) then ; do j=js,je ; do i=is,ie - sfc_state%frazil(i,j) = US%Q_to_J_kg*US%RZ_to_kg_m2 * CS%tv%frazil(i,j) + sfc_state%frazil(i,j) = CS%tv%frazil(i,j) enddo ; enddo ; endif ! copy Hml into sfc_state, so that caps can access it @@ -3209,7 +3208,7 @@ subroutine extract_surface_state(CS, sfc_state_in) if (allocated(sfc_state%melt_potential)) then - !$OMP parallel do default(shared) private(depth_ml, dh, T_freeze, depth, delT) + !$OMP parallel do default(shared) private(depth_ml, dh, T_freeze, depth, delT) do j=js,je do i=is,ie depth(i) = 0.0 @@ -3217,9 +3216,9 @@ subroutine extract_surface_state(CS, sfc_state_in) enddo do k=1,nz ; do i=is,ie - depth_ml = min(CS%HFrz, US%Z_to_m*CS%visc%MLD(i,j)) - if (depth(i) + h(i,j,k)*GV%H_to_m < depth_ml) then - dh = h(i,j,k)*GV%H_to_m + depth_ml = min(CS%HFrz, CS%visc%MLD(i,j)) + if (depth(i) + h(i,j,k)*GV%H_to_Z < depth_ml) then + dh = h(i,j,k)*GV%H_to_Z elseif (depth(i) < depth_ml) then dh = depth_ml - depth(i) else @@ -3237,8 +3236,8 @@ subroutine extract_surface_state(CS, sfc_state_in) sfc_state%melt_potential(i,j) = 0.0 if (G%mask2dT(i,j)>0.) then - ! instantaneous melt_potential [J m-2] - sfc_state%melt_potential(i,j) = US%Q_to_J_kg*US%R_to_kg_m3 * CS%tv%C_p * GV%Rho0 * delT(i) + ! instantaneous melt_potential [Q R Z ~> J m-2] + sfc_state%melt_potential(i,j) = CS%tv%C_p * GV%Rho0 * delT(i) endif enddo enddo ! end of j loop @@ -3248,31 +3247,31 @@ subroutine extract_surface_state(CS, sfc_state_in) !$OMP parallel do default(shared) do j=js,je ; do i=is,ie ! Convert from gSalt to kgSalt - sfc_state%salt_deficit(i,j) = 0.001 * US%RZ_to_kg_m2*CS%tv%salt_deficit(i,j) + sfc_state%salt_deficit(i,j) = 0.001 * CS%tv%salt_deficit(i,j) enddo ; enddo endif if (allocated(sfc_state%TempxPmE) .and. associated(CS%tv%TempxPmE)) then !$OMP parallel do default(shared) do j=js,je ; do i=is,ie - sfc_state%TempxPmE(i,j) = US%RZ_to_kg_m2*CS%tv%TempxPmE(i,j) + sfc_state%TempxPmE(i,j) = CS%tv%TempxPmE(i,j) enddo ; enddo endif if (allocated(sfc_state%internal_heat) .and. associated(CS%tv%internal_heat)) then !$OMP parallel do default(shared) do j=js,je ; do i=is,ie - sfc_state%internal_heat(i,j) = US%RZ_to_kg_m2*CS%tv%internal_heat(i,j) + sfc_state%internal_heat(i,j) = CS%tv%internal_heat(i,j) enddo ; enddo endif if (allocated(sfc_state%taux_shelf) .and. associated(CS%visc%taux_shelf)) then !$OMP parallel do default(shared) do j=js,je ; do I=is-1,ie - sfc_state%taux_shelf(I,j) = US%RZ_T_to_kg_m2s*US%L_T_to_m_s*CS%visc%taux_shelf(I,j) + sfc_state%taux_shelf(I,j) = CS%visc%taux_shelf(I,j) enddo ; enddo endif if (allocated(sfc_state%tauy_shelf) .and. associated(CS%visc%tauy_shelf)) then !$OMP parallel do default(shared) do J=js-1,je ; do i=is,ie - sfc_state%tauy_shelf(i,J) = US%RZ_T_to_kg_m2s*US%L_T_to_m_s*CS%visc%tauy_shelf(i,J) + sfc_state%tauy_shelf(i,J) = CS%visc%tauy_shelf(i,J) enddo ; enddo endif @@ -3285,11 +3284,10 @@ subroutine extract_surface_state(CS, sfc_state_in) enddo ; enddo !$OMP parallel do default(shared) private(mass) do j=js,je ; do k=1,nz; do i=is,ie - mass = GV%H_to_kg_m2*h(i,j,k) + mass = GV%H_to_RZ*h(i,j,k) sfc_state%ocean_mass(i,j) = sfc_state%ocean_mass(i,j) + mass - sfc_state%ocean_heat(i,j) = sfc_state%ocean_heat(i,j) + mass*CS%tv%T(i,j,k) - sfc_state%ocean_salt(i,j) = sfc_state%ocean_salt(i,j) + & - mass * (1.0e-3*CS%tv%S(i,j,k)) + sfc_state%ocean_heat(i,j) = sfc_state%ocean_heat(i,j) + mass * CS%tv%T(i,j,k) + sfc_state%ocean_salt(i,j) = sfc_state%ocean_salt(i,j) + mass * (1.0e-3*CS%tv%S(i,j,k)) enddo ; enddo ; enddo else if (allocated(sfc_state%ocean_mass)) then @@ -3297,7 +3295,7 @@ subroutine extract_surface_state(CS, sfc_state_in) do j=js,je ; do i=is,ie ; sfc_state%ocean_mass(i,j) = 0.0 ; enddo ; enddo !$OMP parallel do default(shared) do j=js,je ; do k=1,nz ; do i=is,ie - sfc_state%ocean_mass(i,j) = sfc_state%ocean_mass(i,j) + GV%H_to_kg_m2*h(i,j,k) + sfc_state%ocean_mass(i,j) = sfc_state%ocean_mass(i,j) + GV%H_to_RZ*h(i,j,k) enddo ; enddo ; enddo endif if (allocated(sfc_state%ocean_heat)) then @@ -3305,7 +3303,7 @@ subroutine extract_surface_state(CS, sfc_state_in) do j=js,je ; do i=is,ie ; sfc_state%ocean_heat(i,j) = 0.0 ; enddo ; enddo !$OMP parallel do default(shared) private(mass) do j=js,je ; do k=1,nz ; do i=is,ie - mass = GV%H_to_kg_m2*h(i,j,k) + mass = GV%H_to_RZ*h(i,j,k) sfc_state%ocean_heat(i,j) = sfc_state%ocean_heat(i,j) + mass*CS%tv%T(i,j,k) enddo ; enddo ; enddo endif @@ -3314,9 +3312,8 @@ subroutine extract_surface_state(CS, sfc_state_in) do j=js,je ; do i=is,ie ; sfc_state%ocean_salt(i,j) = 0.0 ; enddo ; enddo !$OMP parallel do default(shared) private(mass) do j=js,je ; do k=1,nz ; do i=is,ie - mass = GV%H_to_kg_m2*h(i,j,k) - sfc_state%ocean_salt(i,j) = sfc_state%ocean_salt(i,j) + & - mass * (1.0e-3*CS%tv%S(i,j,k)) + mass = GV%H_to_RZ*h(i,j,k) + sfc_state%ocean_salt(i,j) = sfc_state%ocean_salt(i,j) + mass * (1.0e-3*CS%tv%S(i,j,k)) enddo ; enddo ; enddo endif endif @@ -3329,11 +3326,10 @@ subroutine extract_surface_state(CS, sfc_state_in) numberOfErrors=0 ! count number of errors do j=js,je; do i=is,ie if (G%mask2dT(i,j)>0.) then - bathy_m = CS%US%Z_to_m * G%bathyT(i,j) - localError = sfc_state%sea_lev(i,j)<=-bathy_m & - .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) + bathy_m < CS%bad_val_col_thick + 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_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 & @@ -3349,7 +3345,7 @@ subroutine extract_surface_state(CS, sfc_state_in) 'Extreme surface sfc_state detected: i=',ig,'j=',jg, & 'lon=',G%geoLonT(i,j), 'lat=',G%geoLatT(i,j), & 'x=',G%gridLonT(ig), 'y=',G%gridLatT(jg), & - 'D=',bathy_m, 'SSH=',sfc_state%sea_lev(i,j), & + 'D=',CS%US%Z_to_m*G%bathyT(i,j), 'SSH=',CS%US%Z_to_m*sfc_state%sea_lev(i,j), & 'SST=',sfc_state%SST(i,j), 'SSS=',sfc_state%SSS(i,j), & 'U-=',US%L_T_to_m_s*sfc_state%u(I-1,j), 'U+=',US%L_T_to_m_s*sfc_state%u(I,j), & 'V-=',US%L_T_to_m_s*sfc_state%v(i,J-1), 'V+=',US%L_T_to_m_s*sfc_state%v(i,J) @@ -3358,7 +3354,7 @@ subroutine extract_surface_state(CS, sfc_state_in) 'Extreme surface sfc_state detected: i=',ig,'j=',jg, & 'lon=',G%geoLonT(i,j), 'lat=',G%geoLatT(i,j), & 'x=',G%gridLonT(i), 'y=',G%gridLatT(j), & - 'D=',bathy_m, 'SSH=',sfc_state%sea_lev(i,j), & + 'D=',CS%US%Z_to_m*G%bathyT(i,j), 'SSH=',CS%US%Z_to_m*sfc_state%sea_lev(i,j), & 'U-=',US%L_T_to_m_s*sfc_state%u(I-1,j), 'U+=',US%L_T_to_m_s*sfc_state%u(I,j), & 'V-=',US%L_T_to_m_s*sfc_state%v(i,J-1), 'V+=',US%L_T_to_m_s*sfc_state%v(i,J) endif @@ -3377,7 +3373,7 @@ subroutine extract_surface_state(CS, sfc_state_in) endif endif - if (CS%debug) call MOM_surface_chksum("Post extract_sfc", sfc_state, G) + if (CS%debug) call MOM_surface_chksum("Post extract_sfc", sfc_state, G, US) ! Rotate sfc_state back onto the input grid, sfc_state_in if (CS%rotate_index) then diff --git a/src/core/MOM_PressureForce_analytic_FV.F90 b/src/core/MOM_PressureForce_analytic_FV.F90 index 614bf3bc8a..ecadb5c4b9 100644 --- a/src/core/MOM_PressureForce_analytic_FV.F90 +++ b/src/core/MOM_PressureForce_analytic_FV.F90 @@ -142,7 +142,7 @@ subroutine PressureForce_AFV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p dM, & ! The barotropic adjustment to the Montgomery potential to ! account for a reduced gravity model [L2 T-2 ~> m2 s-2]. za ! The geopotential anomaly (i.e. g*e + alpha_0*pressure) at the - ! interface atop a layer [m2 s-2]. + ! interface atop a layer [L2 T-2 ~> m2 s-2]. real, dimension(SZI_(G)) :: Rho_cv_BL ! The coordinate potential density in the deepest variable ! density near-surface layer [R ~> kg m-3]. diff --git a/src/core/MOM_checksum_packages.F90 b/src/core/MOM_checksum_packages.F90 index 47369cf474..70ba32644f 100644 --- a/src/core/MOM_checksum_packages.F90 +++ b/src/core/MOM_checksum_packages.F90 @@ -132,7 +132,7 @@ subroutine MOM_thermo_chksum(mesg, tv, G, US, haloshift) if (associated(tv%T)) call hchksum(tv%T, mesg//" T", G%HI, haloshift=hs) if (associated(tv%S)) call hchksum(tv%S, mesg//" S", G%HI, haloshift=hs) if (associated(tv%frazil)) call hchksum(tv%frazil, mesg//" frazil", G%HI, haloshift=hs, & - scale=G%US%Q_to_J_kg*G%US%R_to_kg_m3*G%US%Z_to_m) + scale=US%Q_to_J_kg*US%R_to_kg_m3*US%Z_to_m) if (associated(tv%salt_deficit)) & call hchksum(tv%salt_deficit, mesg//" salt deficit", G%HI, haloshift=hs, scale=US%RZ_to_kg_m2) @@ -141,12 +141,13 @@ end subroutine MOM_thermo_chksum ! ============================================================================= !> Write out chksums for the ocean surface variables. -subroutine MOM_surface_chksum(mesg, sfc_state, G, haloshift, symmetric) +subroutine MOM_surface_chksum(mesg, sfc_state, G, US, haloshift, symmetric) character(len=*), intent(in) :: mesg !< A message that appears on the chksum lines. type(surface), intent(inout) :: sfc_state !< transparent ocean surface state 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. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type 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 !! computational domain. @@ -159,15 +160,17 @@ subroutine MOM_surface_chksum(mesg, sfc_state, G, haloshift, symmetric) if (allocated(sfc_state%SST)) call hchksum(sfc_state%SST, mesg//" SST", G%HI, haloshift=hs) if (allocated(sfc_state%SSS)) call hchksum(sfc_state%SSS, mesg//" SSS", G%HI, haloshift=hs) - if (allocated(sfc_state%sea_lev)) call hchksum(sfc_state%sea_lev, mesg//" sea_lev", G%HI, haloshift=hs) + if (allocated(sfc_state%sea_lev)) call hchksum(sfc_state%sea_lev, mesg//" sea_lev", G%HI, & + haloshift=hs, scale=US%Z_to_m) if (allocated(sfc_state%Hml)) call hchksum(sfc_state%Hml, mesg//" Hml", G%HI, haloshift=hs, & - scale=G%US%Z_to_m) + scale=US%Z_to_m) if (allocated(sfc_state%u) .and. allocated(sfc_state%v)) & call uvchksum(mesg//" SSU", sfc_state%u, sfc_state%v, G%HI, haloshift=hs, symmetric=sym, & - scale=G%US%L_T_to_m_s) + scale=US%L_T_to_m_s) ! if (allocated(sfc_state%salt_deficit)) & -! call hchksum(sfc_state%salt_deficit, mesg//" salt deficit", G%HI, haloshift=hs) - if (allocated(sfc_state%frazil)) call hchksum(sfc_state%frazil, mesg//" frazil", G%HI, haloshift=hs) +! call hchksum(sfc_state%salt_deficit, mesg//" salt deficit", G%HI, haloshift=hs, scale=US%RZ_to_kg_m2) + if (allocated(sfc_state%frazil)) call hchksum(sfc_state%frazil, mesg//" frazil", G%HI, & + haloshift=hs, scale=US%Q_to_J_kg*US%RZ_to_kg_m2) end subroutine MOM_surface_chksum diff --git a/src/core/MOM_forcing_type.F90 b/src/core/MOM_forcing_type.F90 index aea62826e3..0ff9a4b287 100644 --- a/src/core/MOM_forcing_type.F90 +++ b/src/core/MOM_forcing_type.F90 @@ -97,7 +97,7 @@ module MOM_forcing_type latent_fprec_diag => NULL(), & !< latent [Q R Z T-1 ~> W m-2] from melting fprec (typically < 0) latent_frunoff_diag => NULL() !< latent [Q R Z T-1 ~> W m-2] from melting frunoff (calving) (typically < 0) - ! water mass fluxes into the ocean [kg m-2 s-1]; these fluxes impact the ocean mass + ! water mass fluxes into the ocean [R Z T-1 ~> kg m-2 s-1]; these fluxes impact the ocean mass real, pointer, dimension(:,:) :: & evap => NULL(), & !< (-1)*fresh water flux evaporated out of the ocean [R Z T-1 ~> kg m-2 s-1] lprec => NULL(), & !< precipitating liquid water into the ocean [R Z T-1 ~> kg m-2 s-1] @@ -672,7 +672,7 @@ subroutine extractFluxes1d(G, GV, US, fluxes, optics, nsw, j, dt, & &" exceeds total shortwave of ",1pe17.10,& &" at ",1pg11.4,"E, "1pg11.4,"N.")') & Pen_SW_tot(i), I_Cp_Hconvert*scale*dt * fluxes%sw(i,j), & - G%geoLonT(i,j),G%geoLatT(i,j) + G%geoLonT(i,j), G%geoLatT(i,j) call MOM_error(WARNING,mesg) endif endif @@ -1025,12 +1025,10 @@ subroutine MOM_forcing_chksum(mesg, fluxes, G, US, haloshift) type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type integer, optional, intent(in) :: haloshift !< shift in halo - real :: RZ_T_conversion ! A combination of scaling factors for mass fluxes [kg T m-2 s-1 R-1 Z-1 ~> 1] integer :: is, ie, js, je, nz, hshift is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke hshift = 1 ; if (present(haloshift)) hshift = haloshift - RZ_T_conversion = US%RZ_T_to_kg_m2s ! 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 @@ -1040,7 +1038,7 @@ subroutine MOM_forcing_chksum(mesg, fluxes, G, US, haloshift) if (associated(fluxes%buoy)) & call hchksum(fluxes%buoy, mesg//" fluxes%buoy ", G%HI, haloshift=hshift, scale=US%L_to_m**2*US%s_to_T**3) if (associated(fluxes%sw)) & - call hchksum(fluxes%sw, mesg//" fluxes%sw",G%HI, haloshift=hshift, scale=US%QRZ_T_to_W_m2) + call hchksum(fluxes%sw, mesg//" fluxes%sw", G%HI, haloshift=hshift, scale=US%QRZ_T_to_W_m2) if (associated(fluxes%sw_vis_dir)) & call hchksum(fluxes%sw_vis_dir, mesg//" fluxes%sw_vis_dir", G%HI, haloshift=hshift, scale=US%QRZ_T_to_W_m2) if (associated(fluxes%sw_vis_dif)) & @@ -1063,36 +1061,36 @@ subroutine MOM_forcing_chksum(mesg, fluxes, G, US, haloshift) call hchksum(fluxes%latent_frunoff_diag, mesg//" fluxes%latent_frunoff_diag", G%HI, & haloshift=hshift, scale=US%QRZ_T_to_W_m2) if (associated(fluxes%sens)) & - call hchksum(fluxes%sens, mesg//" fluxes%sens",G%HI,haloshift=hshift, scale=US%QRZ_T_to_W_m2) + call hchksum(fluxes%sens, mesg//" fluxes%sens", G%HI, haloshift=hshift, scale=US%QRZ_T_to_W_m2) if (associated(fluxes%evap)) & - call hchksum(fluxes%evap, mesg//" fluxes%evap",G%HI,haloshift=hshift, scale=RZ_T_conversion) + call hchksum(fluxes%evap, mesg//" fluxes%evap", G%HI, haloshift=hshift, scale=US%RZ_T_to_kg_m2s) if (associated(fluxes%lprec)) & - call hchksum(fluxes%lprec, mesg//" fluxes%lprec",G%HI,haloshift=hshift, scale=RZ_T_conversion) + call hchksum(fluxes%lprec, mesg//" fluxes%lprec", G%HI, haloshift=hshift, scale=US%RZ_T_to_kg_m2s) if (associated(fluxes%fprec)) & - call hchksum(fluxes%fprec, mesg//" fluxes%fprec",G%HI,haloshift=hshift, scale=RZ_T_conversion) + call hchksum(fluxes%fprec, mesg//" fluxes%fprec", G%HI, haloshift=hshift, scale=US%RZ_T_to_kg_m2s) if (associated(fluxes%vprec)) & - call hchksum(fluxes%vprec, mesg//" fluxes%vprec",G%HI,haloshift=hshift, scale=RZ_T_conversion) + call hchksum(fluxes%vprec, mesg//" fluxes%vprec", G%HI, haloshift=hshift, scale=US%RZ_T_to_kg_m2s) if (associated(fluxes%seaice_melt)) & - call hchksum(fluxes%seaice_melt, mesg//" fluxes%seaice_melt",G%HI,haloshift=hshift, scale=RZ_T_conversion) + call hchksum(fluxes%seaice_melt, mesg//" fluxes%seaice_melt", G%HI, haloshift=hshift, scale=US%RZ_T_to_kg_m2s) if (associated(fluxes%seaice_melt_heat)) & call hchksum(fluxes%seaice_melt_heat, mesg//" fluxes%seaice_melt_heat", G%HI, & haloshift=hshift, scale=US%QRZ_T_to_W_m2) if (associated(fluxes%p_surf)) & call hchksum(fluxes%p_surf, mesg//" fluxes%p_surf", G%HI, haloshift=hshift , scale=US%RL2_T2_to_Pa) if (associated(fluxes%salt_flux)) & - call hchksum(fluxes%salt_flux, mesg//" fluxes%salt_flux", G%HI, haloshift=hshift, scale=RZ_T_conversion) + call hchksum(fluxes%salt_flux, mesg//" fluxes%salt_flux", G%HI, haloshift=hshift, scale=US%RZ_T_to_kg_m2s) if (associated(fluxes%TKE_tidal)) & call hchksum(fluxes%TKE_tidal, mesg//" fluxes%TKE_tidal", G%HI, haloshift=hshift, & scale=US%RZ3_T3_to_W_m2) if (associated(fluxes%ustar_tidal)) & - call hchksum(fluxes%ustar_tidal, mesg//" fluxes%ustar_tidal",G%HI,haloshift=hshift, scale=US%Z_to_m*US%s_to_T) + call hchksum(fluxes%ustar_tidal, mesg//" fluxes%ustar_tidal", G%HI, haloshift=hshift, scale=US%Z_to_m*US%s_to_T) if (associated(fluxes%lrunoff)) & - call hchksum(fluxes%lrunoff, mesg//" fluxes%lrunoff",G%HI,haloshift=hshift, scale=RZ_T_conversion) + call hchksum(fluxes%lrunoff, mesg//" fluxes%lrunoff", G%HI, haloshift=hshift, scale=US%RZ_T_to_kg_m2s) if (associated(fluxes%frunoff)) & - call hchksum(fluxes%frunoff, mesg//" fluxes%frunoff",G%HI,haloshift=hshift, scale=RZ_T_conversion) + call hchksum(fluxes%frunoff, mesg//" fluxes%frunoff", G%HI, haloshift=hshift, scale=US%RZ_T_to_kg_m2s) if (associated(fluxes%heat_content_lrunoff)) & call hchksum(fluxes%heat_content_lrunoff, mesg//" fluxes%heat_content_lrunoff", G%HI, & - haloshift=hshift, scale=RZ_T_conversion) + haloshift=hshift, scale=US%RZ_T_to_kg_m2s) if (associated(fluxes%heat_content_frunoff)) & call hchksum(fluxes%heat_content_frunoff, mesg//" fluxes%heat_content_frunoff", G%HI, & haloshift=hshift, scale=US%QRZ_T_to_W_m2) @@ -2065,7 +2063,6 @@ subroutine copy_common_forcing_fields(forces, fluxes, G, skip_pres) 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 [Pa2]. logical :: do_pres integer :: i, j, is, ie, js, je is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec @@ -2203,7 +2200,6 @@ subroutine copy_back_forcing_fields(fluxes, forces, G) type(mech_forcing), intent(inout) :: forces !< A structure with the driving mechanical forces type(ocean_grid_type), intent(in) :: G !< grid type - real :: taux2, tauy2 ! Squared wind stress components [Pa2]. integer :: i, j, is, ie, js, je is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec @@ -2290,9 +2286,8 @@ subroutine forcing_diagnostics(fluxes_in, sfc_state, G_in, US, time_end, diag, h real, dimension(SZI_(diag%G),SZJ_(diag%G)) :: res real :: total_transport ! for diagnosing integrated boundary transport real :: ave_flux ! for diagnosing averaged boundary flux - real :: C_p ! seawater heat capacity [J degC-1 kg-1] real :: RZ_T_conversion ! A combination of scaling factors for mass fluxes [kg T m-2 s-1 R-1 Z-1 ~> 1] - real :: I_dt ! inverse time step [s-1] + real :: I_dt ! inverse time step [T-1 ~> s-1] real :: ppt2mks ! conversion between ppt and mks integer :: turns ! Number of index quarter turns integer :: i,j,is,ie,js,je @@ -2312,9 +2307,8 @@ subroutine forcing_diagnostics(fluxes_in, sfc_state, G_in, US, time_end, diag, h fluxes => fluxes_in endif - C_p = US%Q_to_J_kg*fluxes%C_p RZ_T_conversion = US%RZ_T_to_kg_m2s - I_dt = 1.0 / (US%T_to_s*fluxes%dt_buoy_accum) + I_dt = 1.0 / fluxes%dt_buoy_accum ppt2mks = 1e-3 is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec @@ -2341,7 +2335,7 @@ subroutine forcing_diagnostics(fluxes_in, sfc_state, G_in, US, time_end, diag, h call post_data(handles%id_total_prcme, total_transport, diag) endif if (handles%id_prcme_ga > 0) then - ave_flux = global_area_mean(res,G) + ave_flux = global_area_mean(res, G) call post_data(handles%id_prcme_ga, ave_flux, diag) endif endif @@ -2365,7 +2359,7 @@ subroutine forcing_diagnostics(fluxes_in, sfc_state, G_in, US, time_end, diag, h enddo ; enddo if (handles%id_net_massout > 0) call post_data(handles%id_net_massout, res, diag) if (handles%id_total_net_massout > 0) then - total_transport = global_area_integral(res,G) + total_transport = global_area_integral(res, G) call post_data(handles%id_total_net_massout, total_transport, diag) endif endif @@ -2401,7 +2395,7 @@ subroutine forcing_diagnostics(fluxes_in, sfc_state, G_in, US, time_end, diag, h enddo ; enddo if (handles%id_net_massin > 0) call post_data(handles%id_net_massin, res, diag) if (handles%id_total_net_massin > 0) then - total_transport = global_area_integral(res,G) + total_transport = global_area_integral(res, G) call post_data(handles%id_total_net_massin, total_transport, diag) endif endif @@ -2412,11 +2406,11 @@ subroutine forcing_diagnostics(fluxes_in, sfc_state, G_in, US, time_end, diag, h 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 - total_transport = global_area_integral(fluxes%evap, G, scale=RZ_T_conversion) + total_transport = global_area_integral(fluxes%evap, G, scale=US%RZ_T_to_kg_m2s) call post_data(handles%id_total_evap, total_transport, diag) endif if ((handles%id_evap_ga > 0) .and. associated(fluxes%evap)) then - ave_flux = global_area_mean(fluxes%evap, G, scale=RZ_T_conversion) + ave_flux = global_area_mean(fluxes%evap, G, scale=US%RZ_T_to_kg_m2s) call post_data(handles%id_evap_ga, ave_flux, diag) endif @@ -2426,11 +2420,11 @@ subroutine forcing_diagnostics(fluxes_in, sfc_state, G_in, US, time_end, diag, h enddo ; enddo if (handles%id_precip > 0) call post_data(handles%id_precip, res, diag) if (handles%id_total_precip > 0) then - total_transport = global_area_integral(res,G) + total_transport = global_area_integral(res, G) call post_data(handles%id_total_precip, total_transport, diag) endif if (handles%id_precip_ga > 0) then - ave_flux = global_area_mean(res,G) + ave_flux = global_area_mean(res, G) call post_data(handles%id_precip_ga, ave_flux, diag) endif endif @@ -2438,11 +2432,11 @@ subroutine forcing_diagnostics(fluxes_in, sfc_state, G_in, US, time_end, diag, h 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, scale=RZ_T_conversion) + total_transport = global_area_integral(fluxes%lprec, G, scale=US%RZ_T_to_kg_m2s) call post_data(handles%id_total_lprec, total_transport, diag) endif if (handles%id_lprec_ga > 0) then - ave_flux = global_area_mean(fluxes%lprec, G, scale=RZ_T_conversion) + ave_flux = global_area_mean(fluxes%lprec, G, scale=US%RZ_T_to_kg_m2s) call post_data(handles%id_lprec_ga, ave_flux, diag) endif endif @@ -2450,11 +2444,11 @@ subroutine forcing_diagnostics(fluxes_in, sfc_state, G_in, US, time_end, diag, h 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, scale=RZ_T_conversion) + total_transport = global_area_integral(fluxes%fprec, G, scale=US%RZ_T_to_kg_m2s) call post_data(handles%id_total_fprec, total_transport, diag) endif if (handles%id_fprec_ga > 0) then - ave_flux = global_area_mean(fluxes%fprec, G, scale=RZ_T_conversion) + ave_flux = global_area_mean(fluxes%fprec, G, scale=US%RZ_T_to_kg_m2s) call post_data(handles%id_fprec_ga, ave_flux, diag) endif endif @@ -2462,11 +2456,11 @@ subroutine forcing_diagnostics(fluxes_in, sfc_state, G_in, US, time_end, diag, h 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, scale=RZ_T_conversion) + total_transport = global_area_integral(fluxes%vprec, G, scale=US%RZ_T_to_kg_m2s) call post_data(handles%id_total_vprec, total_transport, diag) endif if (handles%id_vprec_ga > 0) then - ave_flux = global_area_mean(fluxes%vprec, G, scale=RZ_T_conversion) + ave_flux = global_area_mean(fluxes%vprec, G, scale=US%RZ_T_to_kg_m2s) call post_data(handles%id_vprec_ga, ave_flux, diag) endif endif @@ -2474,7 +2468,7 @@ subroutine forcing_diagnostics(fluxes_in, sfc_state, G_in, US, time_end, diag, h 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, scale=RZ_T_conversion) + total_transport = global_area_integral(fluxes%lrunoff, G, scale=US%RZ_T_to_kg_m2s) call post_data(handles%id_total_lrunoff, total_transport, diag) endif endif @@ -2482,7 +2476,7 @@ subroutine forcing_diagnostics(fluxes_in, sfc_state, G_in, US, time_end, diag, h 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, scale=RZ_T_conversion) + total_transport = global_area_integral(fluxes%frunoff, G, scale=US%RZ_T_to_kg_m2s) call post_data(handles%id_total_frunoff, total_transport, diag) endif endif @@ -2490,7 +2484,7 @@ subroutine forcing_diagnostics(fluxes_in, sfc_state, G_in, US, time_end, diag, h if (associated(fluxes%seaice_melt)) then if (handles%id_seaice_melt > 0) call post_data(handles%id_seaice_melt, fluxes%seaice_melt, diag) if (handles%id_total_seaice_melt > 0) then - total_transport = global_area_integral(fluxes%seaice_melt, G, scale=RZ_T_conversion) + total_transport = global_area_integral(fluxes%seaice_melt, G, scale=US%RZ_T_to_kg_m2s) call post_data(handles%id_total_seaice_melt, total_transport, diag) endif endif @@ -2549,7 +2543,7 @@ subroutine forcing_diagnostics(fluxes_in, sfc_state, G_in, US, time_end, diag, h 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 - total_transport = global_area_integral(fluxes%heat_content_massout,G, scale=US%QRZ_T_to_W_m2) + total_transport = global_area_integral(fluxes%heat_content_massout, G, scale=US%QRZ_T_to_W_m2) call post_data(handles%id_total_heat_content_massout, total_transport, diag) endif @@ -2590,9 +2584,9 @@ subroutine forcing_diagnostics(fluxes_in, sfc_state, G_in, US, time_end, diag, h 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%seaice_melt_heat)) res(i,j) = res(i,j) + fluxes%seaice_melt_heat(i,j) - if (allocated(sfc_state%frazil)) res(i,j) = res(i,j) + US%W_m2_to_QRZ_T*sfc_state%frazil(i,j) * I_dt + if (allocated(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) * US%Q_to_J_kg*fluxes%C_p * I_dt + ! 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) @@ -2629,7 +2623,7 @@ subroutine forcing_diagnostics(fluxes_in, sfc_state, G_in, US, time_end, diag, h do j=js,je ; do i=is,ie res(i,j) = 0.0 ! if (associated(sfc_state%TempXpme)) then - ! res(i,j) = res(i,j) + sfc_state%TempXpme(i,j) * US%Q_to_J_kg*fluxes%C_p * I_dt + ! 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) @@ -2800,21 +2794,21 @@ subroutine forcing_diagnostics(fluxes_in, sfc_state, G_in, US, time_end, diag, h 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 - total_transport = ppt2mks*global_area_integral(fluxes%salt_flux, G, scale=RZ_T_conversion) + total_transport = ppt2mks*global_area_integral(fluxes%salt_flux, G, scale=US%RZ_T_to_kg_m2s) call post_data(handles%id_total_saltflux, total_transport, diag) endif 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 - total_transport = ppt2mks*global_area_integral(fluxes%salt_flux_added, G, scale=RZ_T_conversion) + total_transport = ppt2mks*global_area_integral(fluxes%salt_flux_added, G, scale=US%RZ_T_to_kg_m2s) call post_data(handles%id_total_saltFluxAdded, total_transport, diag) endif 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 - total_transport = ppt2mks*global_area_integral(fluxes%salt_flux_in, G, scale=RZ_T_conversion) + total_transport = ppt2mks*global_area_integral(fluxes%salt_flux_in, G, scale=US%RZ_T_to_kg_m2s) call post_data(handles%id_total_saltFluxIn, total_transport, diag) endif diff --git a/src/core/MOM_variables.F90 b/src/core/MOM_variables.F90 index a8a367a7fe..97e5b36db5 100644 --- a/src/core/MOM_variables.F90 +++ b/src/core/MOM_variables.F90 @@ -46,23 +46,23 @@ module MOM_variables Hml, & !< The mixed layer depth [Z ~> m]. u, & !< The mixed layer zonal velocity [L T-1 ~> m s-1]. v, & !< The mixed layer meridional velocity [L T-1 ~> m s-1]. - sea_lev, & !< The sea level [m]. If a reduced surface gravity is + sea_lev, & !< The sea level [Z ~> m]. If a reduced surface gravity is !! used, that is compensated for in sea_lev. frazil, & !< The energy needed to heat the ocean column to the freezing point during - !! the call to step_MOM [J m-2]. - melt_potential, & !< Instantaneous amount of heat that can be used to melt sea ice [J m-2]. + !! the call to step_MOM [Q R Z ~> J m-2]. + melt_potential, & !< Instantaneous amount of heat that can be used to melt sea ice [Q R Z ~> J m-2]. !! This is computed w.r.t. surface freezing temperature. - ocean_mass, & !< The total mass of the ocean [kg m-2]. - ocean_heat, & !< The total heat content of the ocean in [degC kg m-2]. - ocean_salt, & !< The total salt content of the ocean in [kgSalt m-2]. - taux_shelf, & !< The zonal stresses on the ocean under shelves [Pa]. - tauy_shelf, & !< The meridional stresses on the ocean under shelves [Pa]. + ocean_mass, & !< The total mass of the ocean [R Z ~> kg m-2]. + ocean_heat, & !< The total heat content of the ocean in [degC R Z ~> degC kg m-2]. + ocean_salt, & !< The total salt content of the ocean in [kgSalt kg-1 R Z ~> kgSalt m-2]. + taux_shelf, & !< The zonal stresses on the ocean under shelves [R L Z T-2 ~> Pa]. + tauy_shelf, & !< The meridional stresses on the ocean under shelves [R L Z T-2 ~> Pa]. TempxPmE, & !< The net inflow of water into the ocean times the temperature at which this - !! inflow occurs during the call to step_MOM [degC kg m-2]. - salt_deficit, & !< The salt needed to maintain the ocean column at a minimum - !! salinity of 0.01 PSU over the call to step_MOM [kgSalt m-2]. + !! inflow occurs during the call to step_MOM [degC R Z ~> degC kg m-2]. + salt_deficit, & !< The salt needed to maintain the ocean column above a minimum + !! salinity over the call to step_MOM [kgSalt kg-1 R Z ~> kgSalt m-2]. internal_heat !< Any internal or geothermal heat sources that are applied to the ocean - !! integrated over the call to step_MOM [degC kg m-2]. + !! integrated over the call to step_MOM [degC R Z ~> degC kg m-2]. logical :: T_is_conT = .false. !< If true, the temperature variable SST is actually the !! conservative temperature in [degC]. logical :: S_is_absS = .false. !< If true, the salinity variable SSS is actually the diff --git a/src/ice_shelf/MOM_ice_shelf.F90 b/src/ice_shelf/MOM_ice_shelf.F90 index d104dfe82a..891d6b3ea7 100644 --- a/src/ice_shelf/MOM_ice_shelf.F90 +++ b/src/ice_shelf/MOM_ice_shelf.F90 @@ -273,13 +273,12 @@ subroutine shelf_calc_flux(sfc_state, fluxes, Time, time_step, CS, forces) real :: wB_flux_new, dDwB_dwB_in real :: I_Gam_T, I_Gam_S real :: dG_dwB ! The derivative of Gam_turb with wB [T3 Z-2 ~> s3 m-2] - real :: taux2, tauy2 ! The squared surface stresses [Pa]. + real :: taux2, tauy2 ! The squared surface stresses [R2 L2 Z2 T-4 ~> Pa2]. real :: u2_av, v2_av ! The ice-area weighted average squared ocean velocities [L2 T-2 ~> m2 s-2] real :: asu1, asu2 ! Ocean areas covered by ice shelves at neighboring u- real :: asv1, asv2 ! and v-points [L2 ~> m2]. real :: I_au, I_av ! The Adcroft reciprocals of the ice shelf areas at adjacent points [L-2 ~> m-2] - real :: Irho0 ! The inverse of the mean density times unit conversion factors that - ! arise because state uses MKS units [L2 m s2 kg-1 T-2 ~> m3 kg-1]. + real :: Irho0 ! The inverse of the mean density times a unit conversion factor [R-1 L Z-1 ~> m3 kg-1] logical :: Sb_min_set, Sb_max_set 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 @@ -336,14 +335,15 @@ subroutine shelf_calc_flux(sfc_state, fluxes, Time, time_step, CS, forces) call hchksum(sfc_state%sss, "sss before apply melting", G%HI, haloshift=0) call hchksum(sfc_state%u, "u_ml before apply melting", G%HI, haloshift=0, scale=US%L_T_to_m_s) call hchksum(sfc_state%v, "v_ml before apply melting", G%HI, haloshift=0, scale=US%L_T_to_m_s) - call hchksum(sfc_state%ocean_mass, "ocean_mass before apply melting", G%HI, haloshift=0) + call hchksum(sfc_state%ocean_mass, "ocean_mass before apply melting", G%HI, haloshift=0, & + scale=US%RZ_to_kg_m2) endif ! Calculate the friction velocity under ice shelves, using taux_shelf and tauy_shelf if possible. if (allocated(sfc_state%taux_shelf) .and. allocated(sfc_state%tauy_shelf)) then call pass_vector(sfc_state%taux_shelf, sfc_state%tauy_shelf, G%domain, TO_ALL, CGRID_NE) endif - Irho0 = US%m_s_to_L_T**2*US%kg_m3_to_R / CS%Rho_ocn + Irho0 = US%Z_to_L / CS%Rho_ocn do j=js,je ; do i=is,ie ; if (fluxes%frac_shelf_h(i,j) > 0.0) then taux2 = 0.0 ; tauy2 = 0.0 ; u2_av = 0.0 ; v2_av = 0.0 asu1 = (ISS%area_shelf_h(i-1,j) + ISS%area_shelf_h(i,j)) @@ -383,7 +383,7 @@ subroutine shelf_calc_flux(sfc_state, fluxes, Time, time_step, CS, forces) CS%eqn_of_state, EOSdom) do i=is,ie - if ((sfc_state%ocean_mass(i,j) > US%RZ_to_kg_m2*CS%col_mass_melt_threshold) .and. & + if ((sfc_state%ocean_mass(i,j) > CS%col_mass_melt_threshold) .and. & (ISS%area_shelf_h(i,j) > 0.0) .and. CS%isthermo) then if (CS%threeeq) then @@ -616,7 +616,7 @@ subroutine shelf_calc_flux(sfc_state, fluxes, Time, time_step, CS, forces) fluxes%iceshelf_melt(:,:) = ISS%water_flux(:,:) * CS%flux_factor do j=js,je ; do i=is,ie - if ((sfc_state%ocean_mass(i,j) > US%RZ_to_kg_m2*CS%col_mass_melt_threshold) .and. & + if ((sfc_state%ocean_mass(i,j) > CS%col_mass_melt_threshold) .and. & (ISS%area_shelf_h(i,j) > 0.0) .and. (CS%isthermo)) then ! Set melt to zero above a cutoff pressure (CS%Rho_ocn*CS%cutoff_depth*CS%g_Earth). @@ -655,7 +655,7 @@ subroutine shelf_calc_flux(sfc_state, fluxes, Time, time_step, CS, forces) endif ! area_shelf_h enddo ; enddo ! i- and j-loops - ! mass flux [kg s-1], part of ISOMIP diags. + ! mass flux [R Z L2 T-1 ~> kg s-1], part of ISOMIP diags. mass_flux(:,:) = 0.0 mass_flux(:,:) = ISS%water_flux(:,:) * ISS%area_shelf_h(:,:) @@ -690,7 +690,7 @@ subroutine shelf_calc_flux(sfc_state, fluxes, Time, time_step, CS, forces) ! 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, US, US%s_to_T*time_step, Time, & - US%kg_m3_to_R*US%m_to_Z*sfc_state%ocean_mass(:,:), coupled_GL) + sfc_state%ocean_mass(:,:), coupled_GL) endif @@ -890,10 +890,10 @@ subroutine add_shelf_flux(G, US, CS, sfc_state, fluxes) type(forcing), intent(inout) :: fluxes !< A structure of surface fluxes that may be used/updated. ! local variables - real :: frac_shelf !< The fractional area covered by the ice shelf [nondim]. - real :: frac_open !< The fractional area of the ocean that is not covered by the ice shelf [nondim]. - real :: delta_mass_shelf!< Change in ice shelf mass over one time step [kg s-1] - real :: balancing_flux !< The fresh water flux that balances the integrated melt flux [R Z T-1 ~> kg m-2 s-1] + real :: frac_shelf !< The fractional area covered by the ice shelf [nondim]. + real :: frac_open !< The fractional area of the ocean that is not covered by the ice shelf [nondim]. + real :: delta_mass_shelf !< Change in ice shelf mass over one time step [R Z m2 T-1 ~> kg s-1] + real :: balancing_flux !< The fresh water flux that balances the integrated melt flux [R Z T-1 ~> kg m-2 s-1] real :: balancing_area !< total area where the balancing flux is applied [m2] type(time_type) :: dTime !< The time step as a time_type type(time_type) :: Time0 !< The previous time (Time-dt) @@ -905,7 +905,7 @@ subroutine add_shelf_flux(G, US, CS, sfc_state, fluxes) !! the two timesteps at (Time) and (Time-dt) [R Z ~> kg m-2]. real, dimension(SZDI_(G),SZDJ_(G)) :: last_h_shelf !< Ice shelf thickness [Z ~> m] !! at at previous time (Time-dt) - real, dimension(SZDI_(G),SZDJ_(G)) :: last_hmask !< Ice shelf mask + real, dimension(SZDI_(G),SZDJ_(G)) :: last_hmask !< Ice shelf mask [nondim] !! at at previous time (Time-dt) real, dimension(SZDI_(G),SZDJ_(G)) :: last_area_shelf_h !< Ice shelf area [L2 ~> m2] !! at at previous time (Time-dt) @@ -933,7 +933,7 @@ subroutine add_shelf_flux(G, US, CS, sfc_state, fluxes) if (CS%debug) then if (allocated(sfc_state%taux_shelf) .and. allocated(sfc_state%tauy_shelf)) then call uvchksum("tau[xy]_shelf", sfc_state%taux_shelf, sfc_state%tauy_shelf, & - G%HI, haloshift=0) + G%HI, haloshift=0, scale=US%RZ_T_to_kg_m2s*US%L_T_to_m_s) endif endif @@ -1023,7 +1023,7 @@ subroutine add_shelf_flux(G, US, CS, sfc_state, fluxes) ! get total ice shelf mass at (Time-dt) and (Time), in kg do j=js,je ; do i=is,ie ! Just consider the change in the mass of the floating shelf. - if ((sfc_state%ocean_mass(i,j) > US%RZ_to_kg_m2*CS%min_ocean_mass_float) .and. & + if ((sfc_state%ocean_mass(i,j) > CS%min_ocean_mass_float) .and. & (ISS%area_shelf_h(i,j) > 0.0)) then delta_float_mass(i,j) = ISS%mass_shelf(i,j) - last_mass_shelf(i,j) else @@ -1051,7 +1051,7 @@ subroutine add_shelf_flux(G, US, CS, sfc_state, fluxes) enddo ; enddo balancing_area = global_area_integral(bal_frac, G) - if (balancing_area > 0.0) then + if (balancing_area > 0.0) then !### Examine whether the rescaling should be inside the parenthesis. balancing_flux = US%kg_m2s_to_RZ_T*(global_area_integral(ISS%water_flux, G, scale=US%RZ_T_to_kg_m2s, & area=ISS%area_shelf_h) + & delta_mass_shelf ) / balancing_area @@ -1123,7 +1123,7 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl character(len=240) :: Tideamp_file real :: utide ! A tidal velocity [L T-1 ~> m s-1] real :: col_thick_melt_thresh ! An ocean column thickness below which iceshelf melting - ! does not occur [m] + ! does not occur [Z ~> m] if (associated(CS)) then call MOM_error(FATAL, "MOM_ice_shelf.F90, initialize_ice_shelf: "// & "called with an associated control structure.") diff --git a/src/ice_shelf/MOM_marine_ice.F90 b/src/ice_shelf/MOM_marine_ice.F90 index 30121d0c8e..64d4dbfdab 100644 --- a/src/ice_shelf/MOM_marine_ice.F90 +++ b/src/ice_shelf/MOM_marine_ice.F90 @@ -48,8 +48,8 @@ subroutine iceberg_forces(G, forces, use_ice_shelf, sfc_state, time_step, CS) 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 [s]. - type(marine_ice_CS), pointer :: CS !< Pointer to the control structure for MOM_marine_ice + real, intent(in) :: time_step !< The coupling time step [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 [L4 Z-2 T-1 R-1 ~> m5 kg-1 s-1]. integer :: i, j, is, ie, js, je @@ -107,18 +107,17 @@ subroutine iceberg_fluxes(G, US, fluxes, use_ice_shelf, sfc_state, time_step, CS !! 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 [s]. - type(marine_ice_CS), pointer :: CS !< Pointer to the control structure for MOM_marine_ice + type(marine_ice_CS), pointer :: CS !< Pointer to the control structure for MOM_marine_ice real :: fraz ! refreezing rate [R Z T-1 ~> kg m-2 s-1] - real :: I_dt_LHF ! The inverse of the timestep times the latent heat of fusion times unit conversion - ! factors because sfc_state is in MKS units [R Z m2 J-1 T-1 ~> kg J-1 s-1]. + real :: I_dt_LHF ! The inverse of the timestep times the latent heat of fusion times [Q-1 T-1 ~> 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. + ! 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. & @@ -139,7 +138,7 @@ subroutine iceberg_fluxes(G, US, fluxes, use_ice_shelf, sfc_state, time_step, CS !Zero'ing out other fluxes under the tabular icebergs if (CS%berg_area_threshold >= 0.) then - I_dt_LHF = US%W_m2_to_QRZ_T / (time_step * CS%latent_heat_fusion) + I_dt_LHF = 1.0 / (US%s_to_T*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. @@ -149,7 +148,7 @@ subroutine iceberg_fluxes(G, US, fluxes, use_ice_shelf, sfc_state, time_step, CS 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 + ! Add frazil formation diagnosed by the ocean model [Q R Z ~> J m-2] in the ! form of surface layer evaporation [R Z T-1 ~> kg m-2 s-1]. Update lprec in the ! control structure for diagnostic purposes. From c53525eae1cbd37fece82be8b0093da2479bbdec Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Wed, 22 Apr 2020 17:14:25 -0600 Subject: [PATCH 251/316] Clean QG_Leith * Follow Bob's suggestion throughout the code: - remove unnecessary halo updates - change loop indices - make expressions rotationally symmetric - fix bugs in vort_xy_dy and grid_sp_v2 * clean the code by deleting commented lines --- .../lateral/MOM_lateral_mixing_coeffs.F90 | 82 +++++-------------- 1 file changed, 21 insertions(+), 61 deletions(-) diff --git a/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 b/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 index d9543322c9..d616812b2f 100644 --- a/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 +++ b/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 @@ -93,9 +93,6 @@ module MOM_lateral_mixing_coeffs real, dimension(:,:,:), pointer :: & slope_x => NULL(), & !< Zonal isopycnal slope [nondim] slope_y => NULL(), & !< Meridional isopycnal slope [nondim] - !### These are posted as diagnostics but are never set. - N2_u => NULL(), & !< Brunt-Vaisala frequency at u-points [s-2] - N2_v => NULL(), & !< Brunt-Vaisala frequency at v-points [s-2] ebt_struct => NULL() !< Vertical structure function to scale diffusivities with [nondim] real ALLOCABLE_, dimension(NIMEMB_PTR_,NJMEM_) :: & Laplac3_const_u !< Laplacian metric-dependent constants [L3 ~> m3] @@ -470,10 +467,6 @@ subroutine calc_slope_functions(h, tv, dt, G, GV, US, CS) if (CS%id_SN_v > 0) call post_data(CS%id_SN_v, CS%SN_v, CS%diag) if (CS%id_L2u > 0) call post_data(CS%id_L2u, CS%L2u, CS%diag) if (CS%id_L2v > 0) call post_data(CS%id_L2v, CS%L2v, CS%diag) - !### I do not believe that CS%N2_u and CS%N2_v are ever set, but because the contents - ! of CS are public, they might be set somewhere outside of this module. - if (CS%id_N2_u > 0) call post_data(CS%id_N2_u, CS%N2_u, CS%diag) - if (CS%id_N2_v > 0) call post_data(CS%id_N2_v, CS%N2_v, CS%diag) endif end subroutine calc_slope_functions @@ -752,8 +745,6 @@ subroutine calc_QG_Leith_viscosity(CS, G, GV, US, h, k, div_xx_dx, div_xx_dy, vo type(ocean_grid_type), intent(in) :: G !< Ocean grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type -! real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(in) :: u !< Zonal flow [L T-1 ~> m s-1] -! real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(in) :: v !< Meridional flow [L T-1 ~> m s-1] real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(inout) :: h !< Layer thickness [H ~> m or kg m-2] integer, intent(in) :: k !< Layer for which to calculate vorticity magnitude real, dimension(SZIB_(G),SZJ_(G)), intent(in) :: div_xx_dx !< x-derivative of horizontal divergence @@ -764,15 +755,6 @@ subroutine calc_QG_Leith_viscosity(CS, G, GV, US, h, k, div_xx_dx, div_xx_dy, vo !! (d/dx(dv/dx - du/dy)) [L-1 T-1 ~> m-1 s-1] real, dimension(SZIB_(G),SZJ_(G)), intent(inout) :: vort_xy_dy !< y-derivative of vertical vorticity !! (d/dy(dv/dx - du/dy)) [L-1 T-1 ~> m-1 s-1] -! real, dimension(SZI_(G),SZJ_(G)), intent(out) :: Leith_Kh_h !< Leith Laplacian viscosity - !! at h-points [L2 T-1 ~> m2 s-1] -! real, dimension(SZIB_(G),SZJB_(G)), intent(out) :: Leith_Kh_q !< Leith Laplacian viscosity - !! at q-points [L2 T-1 ~> m2 s-1] -! real, dimension(SZI_(G),SZJ_(G)), intent(out) :: Leith_Ah_h !< Leith bi-harmonic viscosity - !! at h-points [L4 T-1 ~> m4 s-1] -! real, dimension(SZIB_(G),SZJB_(G)), intent(out) :: Leith_Ah_q !< Leith bi-harmonic viscosity - !! at q-points [L4 T-1 ~> m4 s-1] - ! Local variables real, dimension(SZI_(G),SZJB_(G)) :: & dslopey_dz, & ! z-derivative of y-slope at v-points [Z-1 ~> m-1] @@ -800,16 +782,9 @@ subroutine calc_QG_Leith_viscosity(CS, G, GV, US, h, k, div_xx_dx, div_xx_dy, vo inv_PI3 = 1.0/((4.0*atan(1.0))**3) - !### I believe this halo update to be unnecessary. -RWH - call pass_var(h, G%Domain) - if ((k > 1) .and. (k < nz)) then - ! Add in stretching term for the QG Leith vsicosity -! if (CS%use_QG_Leith) then - - !### do j=js-1,je+1 ; do I=is-2,Ieq+1 - do j=js-2,Jeq+2 ; do I=is-2,Ieq+1 + do j=js-1,je+1 ; do I=is-2,Ieq+1 h_at_slope_above = 2. * ( h(i,j,k-1) * h(i+1,j,k-1) ) * ( h(i,j,k) * h(i+1,j,k) ) / & ( ( h(i,j,k-1) * h(i+1,j,k-1) ) * ( h(i,j,k) + h(i+1,j,k) ) & + ( h(i,j,k) * h(i+1,j,k) ) * ( h(i,j,k-1) + h(i+1,j,k-1) ) + GV%H_subroundoff ) @@ -821,8 +796,7 @@ subroutine calc_QG_Leith_viscosity(CS, G, GV, US, h, k, div_xx_dx, div_xx_dy, vo h_at_u(I,j) = 2. * ( h_at_slope_above * h_at_slope_below ) * Ih enddo ; enddo - !### do J=js-2,Jeq+1 ; do i=is-1,ie+1 - do J=js-2,Jeq+1 ; do i=is-2,Ieq+2 + do J=js-2,Jeq+1 ; do i=is-1,ie+1 h_at_slope_above = 2. * ( h(i,j,k-1) * h(i,j+1,k-1) ) * ( h(i,j,k) * h(i,j+1,k) ) / & ( ( h(i,j,k-1) * h(i,j+1,k-1) ) * ( h(i,j,k) + h(i,j+1,k) ) & + ( h(i,j,k) * h(i,j+1,k) ) * ( h(i,j,k-1) + h(i,j+1,k-1) ) + GV%H_subroundoff ) @@ -834,8 +808,7 @@ subroutine calc_QG_Leith_viscosity(CS, G, GV, US, h, k, div_xx_dx, div_xx_dy, vo h_at_v(i,J) = 2. * ( h_at_slope_above * h_at_slope_below ) * Ih enddo ; enddo - !### do J=js-1,je ; do i=is-1,Ieq+1 - do J=js-2,Jeq+1 ; do i=is-1,Ieq+1 + do J=js-1,je ; do i=is-1,Ieq+1 f = 0.5 * ( G%CoriolisBu(I,J) + G%CoriolisBu(I-1,J) ) vort_xy_dx(i,J) = vort_xy_dx(i,J) - f * US%L_to_Z * & ( ( h_at_u(I,j) * dslopex_dz(I,j) + h_at_u(I-1,j+1) * dslopex_dz(I-1,j+1) ) & @@ -843,33 +816,25 @@ subroutine calc_QG_Leith_viscosity(CS, G, GV, US, h, k, div_xx_dx, div_xx_dy, vo ( ( h_at_u(I,j) + h_at_u(I-1,j+1) ) + ( h_at_u(I-1,j) + h_at_u(I,j+1) ) + GV%H_subroundoff) enddo ; enddo - !### do j=js-1,Jeq+1 ; do I=is-1,ie - do j=js-1,Jeq+1 ; do I=is-2,Ieq+1 + do j=js-1,Jeq+1 ; do I=is-1,ie f = 0.5 * ( G%CoriolisBu(I,J) + G%CoriolisBu(I,J-1) ) - !### I think that this should be vort_xy_dy(I,j) = vort_xy_dy(I,j) - f * & - vort_xy_dy(I,j) = vort_xy_dx(I,j) - f * US%L_to_Z * & + vort_xy_dy(I,j) = vort_xy_dy(I,j) - f * US%L_to_Z * & ( ( h_at_v(i,J) * dslopey_dz(i,J) + h_at_v(i+1,J-1) * dslopey_dz(i+1,J-1) ) & + ( h_at_v(i,J-1) * dslopey_dz(i,J-1) + h_at_v(i+1,J) * dslopey_dz(i+1,J) ) ) / & ( ( h_at_v(i,J) + h_at_v(i+1,J-1) ) + ( h_at_v(i,J-1) + h_at_v(i+1,J) ) + GV%H_subroundoff) enddo ; enddo endif ! k > 1 - !### I believe this halo update to be unnecessary. -RWH - call pass_vector(vort_xy_dy,vort_xy_dx,G%Domain) - if (CS%use_QG_Leith_GM) then do j=js,je ; do I=is-1,Ieq - !### These expressions are not rotationally symmetric. Add parentheses and regroup, as in: - ! grad_vort_mag_u(I,j) = SQRT(vort_xy_dy(I,j)**2 + (0.25*((vort_xy_dx(i,J) + vort_xy_dx(i+1,J-1)) + - ! (vort_xy_dx(i+1,J) + vort_xy_dx(i,J-1))))**2 ) - grad_vort_mag_u(I,j) = SQRT(vort_xy_dy(I,j)**2 + (0.25*(vort_xy_dx(i,J) + vort_xy_dx(i+1,J) & - + vort_xy_dx(i,J-1) + vort_xy_dx(i+1,J-1)))**2) - grad_div_mag_u(I,j) = SQRT(div_xx_dx(I,j)**2 + (0.25*(div_xx_dy(i,J) + div_xx_dy(i+1,J) & - + div_xx_dy(i,J-1) + div_xx_dy(i+1,J-1)))**2) + grad_vort_mag_u(I,j) = SQRT(vort_xy_dy(I,j)**2 + (0.25*((vort_xy_dx(i,J) + vort_xy_dx(i+1,J-1)) & + + (vort_xy_dx(i+1,J) + vort_xy_dx(i,J-1))))**2) + grad_div_mag_u(I,j) = SQRT(div_xx_dx(I,j)**2 + (0.25*((div_xx_dy(i,J) + div_xx_dy(i+1,J-1)) & + + (div_xx_dy(i+1,J) + div_xx_dy(i,J-1))))**2) if (CS%use_beta_in_QG_Leith) then - beta_u(I,j) = sqrt( (0.5*(G%dF_dx(i,j)+G%dF_dx(i+1,j))**2) + & - (0.5*(G%dF_dy(i,j)+G%dF_dy(i+1,j))**2) ) + beta_u(I,j) = sqrt((0.5*(G%dF_dx(i,j)+G%dF_dx(i+1,j))**2) + & + (0.5*(G%dF_dy(i,j)+G%dF_dy(i+1,j))**2)) CS%KH_u_QG(I,j,k) = MIN(grad_vort_mag_u(I,j) + grad_div_mag_u(I,j), 3.0*beta_u(I,j)) * & CS%Laplac3_const_u(I,j) * inv_PI3 else @@ -879,14 +844,13 @@ subroutine calc_QG_Leith_viscosity(CS, G, GV, US, h, k, div_xx_dx, div_xx_dy, vo enddo ; enddo do J=js-1,Jeq ; do i=is,ie - !### These expressions are not rotationally symmetric. Add parentheses and regroup. - grad_vort_mag_v(i,J) = SQRT(vort_xy_dx(i,J)**2 + (0.25*(vort_xy_dy(I,j) + vort_xy_dy(I-1,j) & - + vort_xy_dy(I,j+1) + vort_xy_dy(I-1,j+1)))**2) - grad_div_mag_v(i,J) = SQRT(div_xx_dy(i,J)**2 + (0.25*(div_xx_dx(I,j) + div_xx_dx(I-1,j) & - + div_xx_dx(I,j+1) + div_xx_dx(I-1,j+1)))**2) + grad_vort_mag_v(i,J) = SQRT(vort_xy_dx(i,J)**2 + (0.25*((vort_xy_dy(I,j) + vort_xy_dy(I-1,j+1)) & + + (vort_xy_dy(I,j+1) + vort_xy_dy(I-1,j))))**2) + grad_div_mag_v(i,J) = SQRT(div_xx_dy(i,J)**2 + (0.25*((div_xx_dx(I,j) + div_xx_dx(I-1,j+1)) & + + (div_xx_dx(I,j+1) + div_xx_dx(I-1,j))))**2) if (CS%use_beta_in_QG_Leith) then - beta_v(i,J) = sqrt( (0.5*(G%dF_dx(i,j)+G%dF_dx(i,j+1))**2) + & - (0.5*(G%dF_dy(i,j)+G%dF_dy(i,j+1))**2) ) + beta_v(i,J) = sqrt((0.5*(G%dF_dx(i,j)+G%dF_dx(i,j+1))**2) + & + (0.5*(G%dF_dy(i,j)+G%dF_dy(i,j+1))**2)) CS%KH_v_QG(i,J,k) = MIN(grad_vort_mag_v(i,J) + grad_div_mag_v(i,J), 3.0*beta_v(i,J)) * & CS%Laplac3_const_v(i,J) * inv_PI3 else @@ -1042,8 +1006,6 @@ subroutine VarMix_init(Time, G, GV, US, param_file, diag, CS) in_use = .true. allocate(CS%slope_x(IsdB:IedB,jsd:jed,G%ke+1)) ; CS%slope_x(:,:,:) = 0.0 allocate(CS%slope_y(isd:ied,JsdB:JedB,G%ke+1)) ; CS%slope_y(:,:,:) = 0.0 - allocate(CS%N2_u(IsdB:IedB,jsd:jed,G%ke+1)) ; CS%N2_u(:,:,:) = 0.0 - allocate(CS%N2_v(isd:ied,JsdB:JedB,G%ke+1)) ; CS%N2_v(:,:,:) = 0.0 call get_param(param_file, mdl, "KD_SMOOTH", CS%kappa_smooth, & "A diapycnal diffusivity that is used to interpolate "//& "more sensible values of T & S into thin layers.", & @@ -1096,11 +1058,10 @@ subroutine VarMix_init(Time, G, GV, US, param_file, diag, CS) 'Square of Brunt-Vaisala frequency, N^2, at u-points, as used in Visbeck et al.', 's-2') CS%id_N2_v = register_diag_field('ocean_model', 'N2_v', diag%axesCvi, Time, & 'Square of Brunt-Vaisala frequency, N^2, at v-points, as used in Visbeck et al.', 's-2') - !### The units of the next two diagnostics should be 'nondim'. CS%id_S2_u = register_diag_field('ocean_model', 'S2_u', diag%axesCu1, Time, & - 'Depth average square of slope magnitude, S^2, at u-points, as used in Visbeck et al.', 's-2') + 'Depth average square of slope magnitude, S^2, at u-points, as used in Visbeck et al.', 'nondim') CS%id_S2_v = register_diag_field('ocean_model', 'S2_v', diag%axesCv1, Time, & - 'Depth average square of slope magnitude, S^2, at v-points, as used in Visbeck et al.', 's-2') + 'Depth average square of slope magnitude, S^2, at v-points, as used in Visbeck et al.', 'nondim') endif oneOrTwo = 1.0 @@ -1272,13 +1233,12 @@ subroutine VarMix_init(Time, G, GV, US, param_file, diag, CS) do j=Jsq,Jeq+1 ; do I=is-1,Ieq ! Static factors in the Leith schemes grid_sp_u2 = G%dyCu(I,j)*G%dxCu(I,j) - grid_sp_u3 = sqrt(grid_sp_u2) + grid_sp_u3 = grid_sp_u2*sqrt(grid_sp_u2) CS%Laplac3_const_u(I,j) = Leith_Lap_const * grid_sp_u3 enddo ; enddo do j=js-1,Jeq ; do I=Isq,Ieq+1 ! Static factors in the Leith schemes - !### The second factor here is wrong. It should be G%dxCv(i,J). - grid_sp_v2 = G%dyCv(i,J)*G%dxCu(i,J) + grid_sp_v2 = G%dyCv(i,J)*G%dxCv(i,J) grid_sp_v3 = grid_sp_v2*sqrt(grid_sp_v2) CS%Laplac3_const_v(i,J) = Leith_Lap_const * grid_sp_v3 enddo ; enddo From b412fde96f2d48592cff2f35a255ef4f386efd2e Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Fri, 1 May 2020 16:40:13 -0600 Subject: [PATCH 252/316] Fix Leith_Ah There were a few mistakes in the Leith AH coefficient calculation that are now fixed. * Use inv_PI6 instead of inv_PI5 * Use Del2vort_q instead of vert_vort_mag --- .../lateral/MOM_hor_visc.F90 | 64 +++++++++---------- 1 file changed, 32 insertions(+), 32 deletions(-) diff --git a/src/parameterizations/lateral/MOM_hor_visc.F90 b/src/parameterizations/lateral/MOM_hor_visc.F90 index c3ec878bc1..c95ddee281 100644 --- a/src/parameterizations/lateral/MOM_hor_visc.F90 +++ b/src/parameterizations/lateral/MOM_hor_visc.F90 @@ -103,11 +103,6 @@ module MOM_hor_visc !< The background biharmonic viscosity at h points [L4 T-1 ~> m4 s-1]. !! The actual viscosity may be the larger of this !! viscosity and the Smagorinsky and Leith viscosities. -! real ALLOCABLE_, dimension(NIMEM_,NJMEM_) :: Biharm5_const2_xx - !< A constant relating the biharmonic viscosity to the - !! square of the velocity shear [L4 T ~> m4 s]. This value is - !! set to be the magnitude of the Coriolis terms once the - !! velocity differences reach a value of order 1/2 MAXVEL. real ALLOCABLE_, dimension(NIMEM_,NJMEM_) :: reduction_xx !< The amount by which stresses through h points are reduced !! due to partial barriers [nondim]. @@ -125,11 +120,6 @@ module MOM_hor_visc !< The background biharmonic viscosity at q points [L4 T-1 ~> m4 s-1]. !! The actual viscosity may be the larger of this !! viscosity and the Smagorinsky and Leith viscosities. -! real ALLOCABLE_, dimension(NIMEMB_PTR_,NJMEMB_PTR_) :: Biharm5_const2_xy - !< A constant relating the biharmonic viscosity to the - !! square of the velocity shear [L4 T ~> m4 s]. This value is - !! set to be the magnitude of the Coriolis terms once the - !! velocity differences reach a value of order 1/2 MAXVEL. real ALLOCABLE_, dimension(NIMEMB_PTR_,NJMEMB_PTR_) :: reduction_xy !< The amount by which stresses through q points are reduced !! due to partial barriers [nondim]. @@ -160,14 +150,14 @@ module MOM_hor_visc ! parameters and metric terms. real ALLOCABLE_, dimension(NIMEM_,NJMEM_) :: & Laplac2_const_xx, & !< Laplacian metric-dependent constants [L2 ~> m2] - Biharm5_const_xx, & !< Biharmonic metric-dependent constants [L5 ~> m5] + Biharm6_const_xx, & !< Biharmonic metric-dependent constants [L6 ~> m6] Laplac3_const_xx, & !< Laplacian metric-dependent constants [L3 ~> m3] Biharm_const_xx, & !< Biharmonic metric-dependent constants [L4 ~> m4] Biharm_const2_xx !< Biharmonic metric-dependent constants [T L4 ~> s m4] real ALLOCABLE_, dimension(NIMEMB_PTR_,NJMEMB_PTR_) :: & Laplac2_const_xy, & !< Laplacian metric-dependent constants [L2 ~> m2] - Biharm5_const_xy, & !< Biharmonic metric-dependent constants [L5 ~> m5] + Biharm6_const_xy, & !< Biharmonic metric-dependent constants [L6 ~> m6] Laplac3_const_xy, & !< Laplacian metric-dependent constants [L3 ~> m3] Biharm_const_xy, & !< Biharmonic metric-dependent constants [L4 ~> m4] Biharm_const2_xy !< Biharmonic metric-dependent constants [T L4 ~> s m4] @@ -256,6 +246,7 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, ! Leith_Ah_h, & ! Leith bi-harmonic viscosity at h-points [L4 T-1 ~> m4 s-1] grad_vort_mag_h, & ! Magnitude of vorticity gradient at h-points [L-1 T-1 ~> m-1 s-1] grad_vort_mag_h_2d, & ! Magnitude of 2d vorticity gradient at h-points [L-1 T-1 ~> m-1 s-1] + Del2vort_h, & ! Laplacian of vorticity at h-points [L-2 T-1 ~> m-2 s-1] grad_div_mag_h, & ! Magnitude of divergence gradient at h-points [L-1 T-1 ~> m-1 s-1] dudx, dvdy, & ! components in the horizontal tension [T-1 ~> s-1] grad_vel_mag_h, & ! Magnitude of the velocity gradient tensor squared at h-points [T-2 ~> s-2] @@ -277,6 +268,7 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, Leith_Ah_q, & ! Leith bi-harmonic viscosity at q-points [L4 T-1 ~> m4 s-1] grad_vort_mag_q, & ! Magnitude of vorticity gradient at q-points [L-1 T-1 ~> m-1 s-1] grad_vort_mag_q_2d, & ! Magnitude of 2d vorticity gradient at q-points [L-1 T-1 ~> m-1 s-1] + Del2vort_q, & ! Laplacian of vorticity at q-points [L-2 T-1 ~> m-2 s-1] grad_div_mag_q, & ! Magnitude of divergence gradient at q-points [L-1 T-1 ~> m-1 s-1] grad_vel_mag_q, & ! Magnitude of the velocity gradient tensor squared at q-points [T-2 ~> s-2] hq, & ! harmonic mean of the harmonic means of the u- & v point thicknesses [H ~> m or kg m-2] @@ -335,6 +327,8 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, real :: FWfrac ! Fraction of maximum theoretical energy transfer to use when scaling GME coefficient [nondim] real :: DY_dxBu ! Ratio of meridional over zonal grid spacing at vertices [nondim] real :: DX_dyBu ! Ratio of zonal over meridiononal grid spacing at vertices [nondim] + real :: DY_dxCv ! Ratio of meridional over zonal grid spacing at faces [nondim] + real :: DX_dyCu ! Ratio of zonal over meridional grid spacing at faces [nondim] real :: Sh_F_pow ! The ratio of shear over the absolute value of f raised to some power and rescaled [nondim] real :: backscat_subround ! The ratio of f over Shear_mag that is so small that the backscatter ! calculation gives the same value as if f were 0 [nondim]. @@ -346,7 +340,7 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, logical :: use_MEKE_Au integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz integer :: i, j, k, n - real :: inv_PI3, inv_PI2, inv_PI5 + real :: inv_PI3, inv_PI2, inv_PI6 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 @@ -354,7 +348,7 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, h_neglect3 = h_neglect**3 inv_PI3 = 1.0/((4.0*atan(1.0))**3) inv_PI2 = 1.0/((4.0*atan(1.0))**2) - inv_PI5 = inv_PI3 * inv_PI2 + inv_PI6 = inv_PI3 * inv_PI3 Ah_h(:,:,:) = 0.0 Kh_h(:,:,:) = 0.0 @@ -465,7 +459,7 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, !$OMP apply_OBC, rescale_Kh, legacy_bound, find_FrictWork, & !$OMP use_MEKE_Ku, use_MEKE_Au, boundary_mask_h, boundary_mask_q, & !$OMP backscat_subround, GME_coeff_limiter, & - !$OMP h_neglect, h_neglect3, FWfrac, inv_PI3, inv_PI5, H0_GME, & + !$OMP h_neglect, h_neglect3, FWfrac, inv_PI3, inv_PI6, H0_GME, & !$OMP diffu, diffv, max_diss_rate_h, max_diss_rate_q, & !$OMP Kh_h, Kh_q, Ah_h, Ah_q, FrictWork, FrictWork_GME, & !$OMP div_xx_h, vort_xy_q, GME_coeff_h, GME_coeff_q, & @@ -502,7 +496,7 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, enddo ; enddo ! Components for the shearing strain - do J=js-2,Jeq+1 ; do I=is-2,Ieq+1 + do J=js-2,Jeq+2 ; do I=is-2,Ieq+2 dvdx(I,J) = CS%DY_dxBu(I,J)*(v(i+1,J,k)*G%IdyCv(i+1,J) - v(i,J,k)*G%IdyCv(i,J)) dudy(I,J) = CS%DX_dyBu(I,J)*(u(I,j+1,k)*G%IdxCu(I,j+1) - u(I,j,k)*G%IdxCu(I,j)) enddo ; enddo @@ -683,26 +677,37 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, ! Vorticity if (CS%no_slip) then - do J=js-2,Jeq+1 ; do I=is-2,Ieq+1 + do J=js-2,Jeq+2 ; do I=is-2,Ieq+2 vort_xy(I,J) = (2.0-G%mask2dBu(I,J)) * ( dvdx(I,J) - dudy(I,J) ) enddo ; enddo else - do J=js-2,Jeq+1 ; do I=is-2,Ieq+1 + do J=js-2,Jeq+2 ; do I=is-2,Ieq+2 vort_xy(I,J) = G%mask2dBu(I,J) * ( dvdx(I,J) - dudy(I,J) ) enddo ; enddo endif ! Vorticity gradient - do J=js-2,Jeq+1 ; do i=is-1,Ieq+1 + do J=js-2,Jeq+2 ; do i=is-1,Ieq+2 DY_dxBu = G%dyBu(I,J) * G%IdxBu(I,J) vort_xy_dx(i,J) = DY_dxBu * (vort_xy(I,J) * G%IdyCu(I,j) - vort_xy(I-1,J) * G%IdyCu(I-1,j)) enddo ; enddo - do j=js-1,Jeq+1 ; do I=is-2,Ieq+1 + do j=js-1,Jeq+2 ; do I=is-2,Ieq+2 DX_dyBu = G%dxBu(I,J) * G%IdyBu(I,J) vort_xy_dy(I,j) = DX_dyBu * (vort_xy(I,J) * G%IdxCv(i,J) - vort_xy(I,J-1) * G%IdxCv(i,J-1)) enddo ; enddo + ! Laplacian of vorticity + do J=Jsq-1,Jeq+1 ; do I=Isq-1,Ieq+1 + DY_dxCv = G%dyCv(i,J) * G%IdxCv(i,J) + DX_dyCu = G%dyCu(I,j) * G%IdyCu(I,j) + Del2vort_q(I,J) = DY_dxCv * (vort_xy_dx(i+1,J) * G%IdyT(i+1,j) - vort_xy_dx(i,J) * G%IdyT(i,j)) + & + DX_dyCu * (vort_xy_dy(I,j+1) * G%IdyT(i,j+1) - vort_xy_dy(I,j) * G%IdyT(i,j)) + enddo ; enddo + do J=Jsq,Jeq+1 ; do I=Isq,Ieq+1 + Del2vort_h(i,j) = 0.25*(Del2vort_q(I,J) + Del2vort_q(I-1,J) + Del2vort_q(I,J-1) + Del2vort_q(I-1,J-1)) + enddo ; enddo + if (CS%modified_Leith) then ! Divergence do j=Jsq-1,Jeq+2 ; do i=Isq-1,Ieq+2 @@ -864,7 +869,7 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, AhSm = CS%Biharm_const_xx(i,j) * Shear_mag endif endif - if (CS%Leith_Ah) AhLth = CS%Biharm5_const_xx(i,j) * vert_vort_mag * inv_PI5 + if (CS%Leith_Ah) AhLth = CS%Biharm6_const_xx(i,j) * abs(Del2vort_h(i,j)) * inv_PI6 Ah = MAX(MAX(CS%Ah_bg_xx(i,j), AhSm), AhLth) if (CS%bound_Ah .and. .not.CS%better_bound_Ah) & Ah = MIN(Ah, CS%Ah_Max_xx(i,j)) @@ -1034,7 +1039,7 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, AhSm = CS%Biharm_const_xy(I,J) * Shear_mag endif endif - if (CS%Leith_Ah) AhLth = CS%Biharm5_const_xy(I,J) * vert_vort_mag * inv_PI5 + if (CS%Leith_Ah) AhLth = CS%Biharm6_const_xy(I,J) * abs(Del2vort_q(I,J)) * inv_PI6 Ah = MAX(MAX(CS%Ah_bg_xy(I,J), AhSm), AhLth) if (CS%bound_Ah .and. .not.CS%better_bound_Ah) & Ah = MIN(Ah, CS%Ah_Max_xy(I,J)) @@ -1745,8 +1750,8 @@ subroutine hor_visc_init(Time, G, US, param_file, diag, CS, MEKE) endif endif if (CS%Leith_Ah) then - ALLOC_(CS%biharm5_const_xx(isd:ied,jsd:jed)) ; CS%biharm5_const_xx(:,:) = 0.0 - ALLOC_(CS%biharm5_const_xy(IsdB:IedB,JsdB:JedB)) ; CS%biharm5_const_xy(:,:) = 0.0 + ALLOC_(CS%biharm6_const_xx(isd:ied,jsd:jed)) ; CS%biharm6_const_xx(:,:) = 0.0 + ALLOC_(CS%biharm6_const_xy(IsdB:IedB,JsdB:JedB)) ; CS%biharm6_const_xy(:,:) = 0.0 endif endif @@ -1870,7 +1875,6 @@ subroutine hor_visc_init(Time, G, US, param_file, diag, CS, MEKE) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 grid_sp_h2 = (2.0*CS%dx2h(i,j)*CS%dy2h(i,j)) / (CS%dx2h(i,j)+CS%dy2h(i,j)) grid_sp_h3 = grid_sp_h2*sqrt(grid_sp_h2) - if (CS%Smagorinsky_Ah) then CS%Biharm_const_xx(i,j) = Smag_bi_const * (grid_sp_h2 * grid_sp_h2) if (CS%bound_Coriolis) then @@ -1881,7 +1885,7 @@ subroutine hor_visc_init(Time, G, US, param_file, diag, CS, MEKE) endif endif if (CS%Leith_Ah) then - CS%biharm5_const_xx(i,j) = Leith_bi_const * (grid_sp_h3 * grid_sp_h2) + CS%biharm6_const_xx(i,j) = Leith_bi_const * (grid_sp_h3 * grid_sp_h3) endif CS%Ah_bg_xx(i,j) = MAX(Ah, Ah_vel_scale * grid_sp_h2 * sqrt(grid_sp_h2)) if (Ah_time_scale > 0.) CS%Ah_bg_xx(i,j) = & @@ -1903,7 +1907,7 @@ subroutine hor_visc_init(Time, G, US, param_file, diag, CS, MEKE) endif endif if (CS%Leith_Ah) then - CS%biharm5_const_xy(i,j) = Leith_bi_const * (grid_sp_q3 * grid_sp_q2) + CS%biharm6_const_xy(i,j) = Leith_bi_const * (grid_sp_q3 * grid_sp_q3) endif CS%Ah_bg_xy(I,J) = MAX(Ah, Ah_vel_scale * grid_sp_q2 * sqrt(grid_sp_q2)) @@ -2035,7 +2039,6 @@ subroutine hor_visc_init(Time, G, US, param_file, diag, CS, MEKE) CS%id_Kh_q = register_diag_field('ocean_model', 'Khq', diag%axesBL, Time, & 'Laplacian Horizontal Viscosity at q Points', 'm2 s-1', conversion=US%L_to_m**2*US%s_to_T) - if (CS%Leith_Kh) then CS%id_vort_xy_q = register_diag_field('ocean_model', 'vort_xy_q', diag%axesBL, Time, & 'Vertical vorticity at q Points', 's-1', conversion=US%s_to_T) @@ -2199,10 +2202,7 @@ subroutine hor_visc_end(CS) DEALLOC_(CS%Ah_Max_xx) ; DEALLOC_(CS%Ah_Max_xy) endif if (CS%Smagorinsky_Ah) then - DEALLOC_(CS%Biharm5_const_xx) ; DEALLOC_(CS%Biharm5_const_xy) - ! if (CS%bound_Coriolis) then - ! DEALLOC_(CS%Biharm5_const2_xx) ; DEALLOC_(CS%Biharm5_const2_xy) - ! endif + DEALLOC_(CS%Biharm6_const_xx) ; DEALLOC_(CS%Biharm6_const_xy) endif if (CS%Leith_Ah) then DEALLOC_(CS%Biharm_const_xx) ; DEALLOC_(CS%Biharm_const_xy) From 7d228f73a1b098da434a59e54dd9b9c2f5978292 Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Mon, 4 May 2020 10:29:48 -0600 Subject: [PATCH 253/316] Add missing OMP directives --- src/parameterizations/lateral/MOM_hor_visc.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/parameterizations/lateral/MOM_hor_visc.F90 b/src/parameterizations/lateral/MOM_hor_visc.F90 index c95ddee281..11fd7b6644 100644 --- a/src/parameterizations/lateral/MOM_hor_visc.F90 +++ b/src/parameterizations/lateral/MOM_hor_visc.F90 @@ -477,8 +477,8 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, !$OMP grad_vel_mag_bt_h, grad_vel_mag_bt_q, grad_d2vel_mag_h, & !$OMP meke_res_fn, Shear_mag, vert_vort_mag, hrat_min, visc_bound_rem, & !$OMP Kh, Ah, AhSm, AhLth, local_strain, Sh_F_pow, & - !$OMP dDel2vdx, dDel2udy, & - !$OMP h2uq, h2vq, hu, hv, hq, FatH, RoScl, GME_coeff & + !$OMP dDel2vdx, dDel2udy, DY_dxCv, DX_dyCu, Del2vort_q, Del2vort_h, & + !$OMP h2uq, h2vq, hu, hv, hq, FatH, RoScl, GME_coeff, KE & !$OMP ) do k=1,nz From 933b09abea4fbc2152ed497ba98a07f46d41dc10 Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Mon, 4 May 2020 14:26:04 -0600 Subject: [PATCH 254/316] Remove OMP directive that came with cherry-picking --- src/parameterizations/lateral/MOM_hor_visc.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/parameterizations/lateral/MOM_hor_visc.F90 b/src/parameterizations/lateral/MOM_hor_visc.F90 index 11fd7b6644..3aac2c6b38 100644 --- a/src/parameterizations/lateral/MOM_hor_visc.F90 +++ b/src/parameterizations/lateral/MOM_hor_visc.F90 @@ -478,7 +478,7 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, !$OMP meke_res_fn, Shear_mag, vert_vort_mag, hrat_min, visc_bound_rem, & !$OMP Kh, Ah, AhSm, AhLth, local_strain, Sh_F_pow, & !$OMP dDel2vdx, dDel2udy, DY_dxCv, DX_dyCu, Del2vort_q, Del2vort_h, & - !$OMP h2uq, h2vq, hu, hv, hq, FatH, RoScl, GME_coeff, KE & + !$OMP h2uq, h2vq, hu, hv, hq, FatH, RoScl, GME_coeff & !$OMP ) do k=1,nz From 3a04ca549a982f3dcb504a82fd41ce5744c5725a Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Mon, 4 May 2020 16:38:56 -0400 Subject: [PATCH 255/316] Scalar diag conversion; Q and R dimension scaling This patch adds support for enthalpy (Q) and density (R) dimensional scaling into the test suite. It also resolves an issue with conversion scaling in scalars (post_data_0d) which were not being applied, and make it impossible to verify the dimensions of scalar diagnostics. --- .testing/Makefile | 14 +++++++++----- src/framework/MOM_diag_mediator.F90 | 12 +++++++++--- 2 files changed, 18 insertions(+), 8 deletions(-) diff --git a/.testing/Makefile b/.testing/Makefile index 0d73979204..99672268c3 100644 --- a/.testing/Makefile +++ b/.testing/Makefile @@ -1,4 +1,5 @@ SHELL = bash +.SUFFIXES: # User-defined configuration -include config.mk @@ -30,9 +31,9 @@ MKMF_CPP = "-Duse_libMPI -Duse_netCDF -DSPMD" # Environment # TODO: This info ought to be determined by CMake, automake, etc. -#MKMF_TEMPLATE ?= .testing/linux-ubuntu-xenial-gnu.mk -MKMF_TEMPLATE ?= build/mkmf/templates/ncrc-gnu.mk -#MKMF_TEMPLATE ?= build/mkmf/templates/ncrc-intel.mk +#MKMF_TEMPLATE ?= linux-ubuntu-xenial-gnu.mk +MKMF_TEMPLATE ?= deps/mkmf/templates/ncrc-gnu.mk +#MKMF_TEMPLATE ?= deps/mkmf/templates/ncrc-intel.mk #--- # Test configuration @@ -41,6 +42,7 @@ MKMF_TEMPLATE ?= build/mkmf/templates/ncrc-gnu.mk BUILDS = symmetric asymmetric repro openmp CONFIGS := $(wildcard tc*) TESTS = grids layouts restarts nans dims openmps rotations +DIMS = t l h z q r # REPRO tests enable reproducibility with optimization, and often do not match # the DEBUG results in older GCCs and vendor compilers, so we can optionally @@ -199,7 +201,7 @@ test.restarts: $(foreach c,$(CONFIGS),$(c).restart) test.repros: $(foreach c,$(CONFIGS),$(c).repro $(c).repro.diag) test.openmps: $(foreach c,$(CONFIGS),$(c).openmp $(c).openmp.diag) test.nans: $(foreach c,$(CONFIGS),$(c).nan $(c).nan.diag) -test.dims: $(foreach c,$(CONFIGS),$(foreach d,t l h z,$(c).dim.$(d) $(c).dim.$(d).diag)) +test.dims: $(foreach c,$(CONFIGS),$(foreach d,$(DIMS),$(c).dim.$(d) $(c).dim.$(d).diag)) test.regressions: $(foreach c,$(CONFIGS),$(c).regression $(c).regression.diag) ! ls -1 results/*/*.reg @@ -220,7 +222,7 @@ $(eval $(call CMP_RULE,rotate,symmetric rotate)) $(eval $(call CMP_RULE,repro,symmetric repro)) $(eval $(call CMP_RULE,openmp,symmetric openmp)) $(eval $(call CMP_RULE,nan,symmetric nan)) -$(foreach d,t l h z,$(eval $(call CMP_RULE,dim.$(d),symmetric dim.$(d)))) +$(foreach d,$(DIMS),$(eval $(call CMP_RULE,dim.$(d),symmetric dim.$(d)))) # Custom comparison rules @@ -295,6 +297,8 @@ $(eval $(call STAT_RULE,dim.t,symmetric,,T_RESCALE_POWER=11,,1)) $(eval $(call STAT_RULE,dim.l,symmetric,,L_RESCALE_POWER=11,,1)) $(eval $(call STAT_RULE,dim.h,symmetric,,H_RESCALE_POWER=11,,1)) $(eval $(call STAT_RULE,dim.z,symmetric,,Z_RESCALE_POWER=11,,1)) +$(eval $(call STAT_RULE,dim.q,symmetric,,Q_RESCALE_POWER=11,,1)) +$(eval $(call STAT_RULE,dim.r,symmetric,,R_RESCALE_POWER=11,,1)) # Restart tests require significant preprocessing, and are handled separately. results/%/ocean.stats.restart: build/symmetric/MOM6 diff --git a/src/framework/MOM_diag_mediator.F90 b/src/framework/MOM_diag_mediator.F90 index 0fcee7624a..03de6405fe 100644 --- a/src/framework/MOM_diag_mediator.F90 +++ b/src/framework/MOM_diag_mediator.F90 @@ -1212,6 +1212,7 @@ subroutine post_data_0d(diag_field_id, field, diag_cs, is_static) logical, optional, intent(in) :: is_static !< If true, this is a static field that is always offered. ! Local variables + real :: locfield logical :: used, is_stat type(diag_type), pointer :: diag => null() @@ -1223,13 +1224,18 @@ subroutine post_data_0d(diag_field_id, field, diag_cs, is_static) call assert(diag_field_id < diag_cs%next_free_diag_id, & 'post_data_0d: Unregistered diagnostic id') diag => diag_cs%diags(diag_field_id) + do while (associated(diag)) + locfield = field + if (diag%conversion_factor /= 0.) & + locfield = locfield * diag%conversion_factor + if (diag_cs%diag_as_chksum) then - call chksum0(field, diag%debug_str, logunit=diag_cs%chksum_iounit) + call chksum0(locfield, diag%debug_str, logunit=diag_cs%chksum_iounit) else if (is_stat) then - used = send_data(diag%fms_diag_id, field) + used = send_data(diag%fms_diag_id, locfield) elseif (diag_cs%ave_enabled) then - used = send_data(diag%fms_diag_id, field, diag_cs%time_end) + used = send_data(diag%fms_diag_id, locfield, diag_cs%time_end) endif diag => diag%next enddo From c06515f19878517e1de6477f69c609005067b045 Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Wed, 6 May 2020 10:15:06 -0600 Subject: [PATCH 256/316] Add tidal diffusivities (Kd_tidal) into Kd_int --- .../vertical/MOM_tidal_mixing.F90 | 20 +++++++++++++++---- 1 file changed, 16 insertions(+), 4 deletions(-) diff --git a/src/parameterizations/vertical/MOM_tidal_mixing.F90 b/src/parameterizations/vertical/MOM_tidal_mixing.F90 index 887cc6d067..14e72f97ea 100644 --- a/src/parameterizations/vertical/MOM_tidal_mixing.F90 +++ b/src/parameterizations/vertical/MOM_tidal_mixing.F90 @@ -681,7 +681,7 @@ subroutine calculate_tidal_mixing(h, N2_bot, j, TKE_to_Kd, max_TKE, G, GV, US, C real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & intent(inout) :: Kd_lay !< The diapycnal diffusvity in layers [Z2 T-1 ~> m2 s-1]. real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1), & - optional, intent(inout) :: Kd_int !< The diapycnal diffusvity at interfaces, + optional, intent(inout) :: Kd_int !< The diapycnal diffusvity at interfaces, !! [Z2 T-1 ~> m2 s-1]. real, intent(in) :: Kd_max !< The maximum increment for diapycnal !! diffusivity due to TKE-based processes, @@ -692,7 +692,7 @@ subroutine calculate_tidal_mixing(h, N2_bot, j, TKE_to_Kd, max_TKE, G, GV, US, C 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, US, CS, N2_int, Kd_lay, Kv) + call calculate_CVMix_tidal(h, j, G, GV, US, CS, N2_int, Kd_lay, Kd_int, Kv) else call add_int_tide_diffusivity(h, N2_bot, j, TKE_to_Kd, max_TKE, & G, GV, US, CS, N2_lay, Kd_lay, Kd_int, Kd_max) @@ -703,7 +703,7 @@ end subroutine calculate_tidal_mixing !> 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, US, CS, N2_int, Kd_lay, Kv) +subroutine calculate_CVMix_tidal(h, j, G, GV, US, CS, N2_int, Kd_lay, Kd_int, Kv) integer, intent(in) :: j !< The j-index to work on type(ocean_grid_type), intent(in) :: G !< Grid structure. type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure @@ -715,6 +715,9 @@ subroutine calculate_CVMix_tidal(h, j, G, GV, US, CS, N2_int, Kd_lay, Kv) intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2]. real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & intent(inout) :: Kd_lay!< The diapycnal diffusivities in the layers [Z2 T-1 ~> m2 s-1]. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1), & + optional, intent(inout) :: Kd_int !< The diapycnal diffusvity at interfaces, + !! [Z2 T-1 ~> m2 s-1]. real, dimension(:,:,:), pointer :: Kv !< The "slow" vertical viscosity at each interface !! (not layer!) [Z2 T-1 ~> m2 s-1]. ! Local variables @@ -794,7 +797,11 @@ subroutine calculate_CVMix_tidal(h, j, G, GV, US, CS, N2_int, Kd_lay, Kv) do k=1,G%ke Kd_lay(i,j,k) = Kd_lay(i,j,k) + 0.5 * US%m2_s_to_Z2_T * (Kd_tidal(k) + Kd_tidal(k+1)) enddo - + if (present(Kd_int)) then + do k=1,G%ke+1 + Kd_int(i,j,k) = Kd_int(i,j,k) + (US%m2_s_to_Z2_T * Kd_tidal(k)) + enddo + endif ! Update viscosity with the proper unit conversion. if (associated(Kv)) then do k=1,G%ke+1 @@ -896,6 +903,11 @@ subroutine calculate_CVMix_tidal(h, j, G, GV, US, CS, N2_int, Kd_lay, Kv) do k=1,G%ke Kd_lay(i,j,k) = Kd_lay(i,j,k) + 0.5 * US%m2_s_to_Z2_T * (Kd_tidal(k) + Kd_tidal(k+1)) enddo + if (present(Kd_int)) then + do k=1,G%ke+1 + Kd_int(i,j,k) = Kd_int(i,j,k) + (US%m2_s_to_Z2_T * Kd_tidal(k)) + enddo + endif ! Update viscosity if (associated(Kv)) then From e05054ef10abd72772a4593f1fa14413613803f1 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 7 May 2020 07:57:40 -0400 Subject: [PATCH 257/316] +Fix units in comments and parameter descriptions Corrected the reported units for several parameters and the units in a number of comments. This changes some comments in MOM_parameter_doc files. All answers are bitwise identical. --- src/core/MOM_isopycnal_slopes.F90 | 4 ++-- src/core/MOM_open_boundary.F90 | 24 ++++++++----------- .../MOM_state_initialization.F90 | 11 ++++----- .../vertical/MOM_tidal_mixing.F90 | 2 +- 4 files changed, 18 insertions(+), 23 deletions(-) diff --git a/src/core/MOM_isopycnal_slopes.F90 b/src/core/MOM_isopycnal_slopes.F90 index 53f0d59294..fa60fb821d 100644 --- a/src/core/MOM_isopycnal_slopes.F90 +++ b/src/core/MOM_isopycnal_slopes.F90 @@ -242,7 +242,7 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, & slope_x(I,j,K) = 0.0 endif - if (present_N2_u) N2_u(I,j,k) = G_Rho0 * drdz * G%mask2dCu(I,j) ! Square of Brunt-Vaisala frequency [s-2] + if (present_N2_u) N2_u(I,j,k) = G_Rho0 * drdz * G%mask2dCu(I,j) ! Square of buoyancy frequency [T-2 ~> s-2] else ! With .not.use_EOS, the layers are constant density. slope_x(I,j,K) = (Z_to_L*(e(i,j,K)-e(i+1,j,K))) * G%IdxCu(I,j) @@ -328,7 +328,7 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, & slope_y(i,J,K) = 0.0 endif - if (present_N2_v) N2_v(i,J,k) = G_Rho0 * drdz * G%mask2dCv(i,J) ! Square of Brunt-Vaisala frequency [s-2] + if (present_N2_v) N2_v(i,J,k) = G_Rho0 * drdz * G%mask2dCv(i,J) ! Square of buoyancy frequency [T-2 ~> s-2] else ! With .not.use_EOS, the layers are constant density. slope_y(i,J,K) = (Z_to_L*(e(i,j,K)-e(i,j+1,K))) * G%IdyCv(i,J) diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index ffede1c0c2..5b6dc168f4 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -265,10 +265,8 @@ module MOM_open_boundary !! velocities (or speed of characteristics) at the !! new time level (1) or the running mean (0) for velocities. !! Valid values range from 0 to 1, with a default of 0.3. - real :: rx_max !< The maximum magnitude of the baroclinic radiation - !! velocity (or speed of characteristics) [m s-1]. The - !! default value is 10 m s-1. - !### The description above seems inconsistent with the code, and the units should be [nondim]. + real :: rx_max !< The maximum magnitude of the baroclinic radiation velocity (or speed of + !! characteristics) in units of grid points per timestep [nondim]. logical :: OBC_pe !< Is there an open boundary on this tile? type(remapping_CS), pointer :: remap_CS !< ALE remapping control structure for segments only type(OBC_registry_type), pointer :: OBC_Reg => NULL() !< Registry type for boundaries @@ -500,13 +498,11 @@ subroutine open_boundary_config(G, US, param_file, OBC) call initialize_segment_data(G, OBC, param_file) if (open_boundary_query(OBC, apply_open_OBC=.true.)) then - !### I think that OBC%rx_max as used is actually nondimensional, with effective - ! units of grid points per time step. call get_param(param_file, mdl, "OBC_RADIATION_MAX", OBC%rx_max, & - "The maximum magnitude of the baroclinic radiation "//& - "velocity (or speed of characteristics). This is only "//& + "The maximum magnitude of the baroclinic radiation velocity (or speed of "//& + "characteristics), in gridpoints per timestep. This is only "//& "used if one of the open boundary segments is using Orlanski.", & - units="m s-1", default=10.0) !### Should the units here be "nondim"? + units="nondim", default=10.0) !### Should the default be changed to 1.0? call get_param(param_file, mdl, "OBC_RAD_VEL_WT", OBC%gamma_uv, & "The relative weighting for the baroclinic radiation "//& "velocities (or speed of characteristics) at the new "//& @@ -1804,9 +1800,9 @@ subroutine open_boundary_impose_land_mask(OBC, G, areaCu, areaCv, US) I=segment%HI%IsdB do j=segment%HI%jsd,segment%HI%jed if (segment%direction == OBC_DIRECTION_E) then - areaCu(I,j) = G%areaT(i,j) ! Both of these are in [L2] + areaCu(I,j) = G%areaT(i,j) ! Both of these are in [L2 ~> m2] else ! West - areaCu(I,j) = G%areaT(i+1,j) ! Both of these are in [L2] + areaCu(I,j) = G%areaT(i+1,j) ! Both of these are in [L2 ~> m2] endif enddo else @@ -1814,9 +1810,9 @@ subroutine open_boundary_impose_land_mask(OBC, G, areaCu, areaCv, US) J=segment%HI%JsdB do i=segment%HI%isd,segment%HI%ied if (segment%direction == OBC_DIRECTION_S) then - areaCv(i,J) = G%areaT(i,j+1) ! Both of these are in [L2] + areaCv(i,J) = G%areaT(i,j+1) ! Both of these are in [L2 ~> m2] else ! North - areaCu(i,J) = G%areaT(i,j) ! Both of these are in [L2] + areaCu(i,J) = G%areaT(i,j) ! Both of these are in [L2 ~> m2] endif enddo endif @@ -1906,7 +1902,7 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, US, dt) real :: dhdt, dhdx, dhdy ! One-point differences in time or space [L T-1 ~> m s-1] real :: gamma_u, gamma_2 ! Fractional weightings of new values [nondim] real :: tau ! A local nudging timescale [T ~> s] - real :: rx_max, ry_max ! coefficients for radiation [nondim] or [L2 T-2 ~> m2 s-2] + real :: rx_max, ry_max ! coefficients for radiation [nondim] real :: rx_new, rx_avg ! coefficients for radiation [nondim] or [L2 T-2 ~> m2 s-2] real :: ry_new, ry_avg ! coefficients for radiation [nondim] or [L2 T-2 ~> m2 s-2] real :: cff_new, cff_avg ! denominator in oblique [L2 T-2 ~> m2 s-2] diff --git a/src/initialization/MOM_state_initialization.F90 b/src/initialization/MOM_state_initialization.F90 index beeaf6e46a..07d928d76b 100644 --- a/src/initialization/MOM_state_initialization.F90 +++ b/src/initialization/MOM_state_initialization.F90 @@ -1108,11 +1108,11 @@ subroutine trim_for_ice(PF, G, GV, US, ALE_CSp, tv, h, just_read_params) just_read = .false. ; if (present(just_read_params)) just_read = just_read_params call get_param(PF, mdl, "SURFACE_PRESSURE_FILE", p_surf_file, & - "The initial condition file for the surface height.", & + "The initial condition file for the surface pressure exerted by ice.", & fail_if_missing=.not.just_read, do_not_log=just_read) call get_param(PF, mdl, "SURFACE_PRESSURE_VAR", p_surf_var, & - "The initial condition variable for the surface height.", & - units="kg m-2", default="", do_not_log=just_read) !### The units here should be Pa? + "The initial condition variable for the surface pressure exerted by ice.", & + units="Pa", default="", do_not_log=just_read) call get_param(PF, mdl, "INPUTDIR", inputdir, default=".", do_not_log=.true.) filename = trim(slasher(inputdir))//trim(p_surf_file) if (.not.just_read) call log_param(PF, mdl, "!INPUTDIR/SURFACE_HEIGHT_IC_FILE", filename) @@ -2177,14 +2177,13 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, G, GV, US, PF, just_read_param ! to the North/South Pole past the limits of the input data, they are extrapolated using the average ! value at the northernmost/southernmost latitude. - call horiz_interp_and_extrap_tracer(tfilename, potemp_var, 1.0, 1, & G, temp_z, mask_z, z_in, z_edges_in, missing_value_temp, reentrant_x, & - tripolar_n, homogenize, m_to_Z=US%m_to_Z, answers_2018=hor_regrid_answers_2018,ongrid=pre_gridded) + tripolar_n, homogenize, m_to_Z=US%m_to_Z, answers_2018=hor_regrid_answers_2018, ongrid=pre_gridded) call horiz_interp_and_extrap_tracer(sfilename, salin_var, 1.0, 1, & G, salt_z, mask_z, z_in, z_edges_in, missing_value_salt, reentrant_x, & - tripolar_n, homogenize, m_to_Z=US%m_to_Z, answers_2018=hor_regrid_answers_2018,ongrid=pre_gridded) + tripolar_n, homogenize, m_to_Z=US%m_to_Z, answers_2018=hor_regrid_answers_2018, ongrid=pre_gridded) kd = size(z_in,1) diff --git a/src/parameterizations/vertical/MOM_tidal_mixing.F90 b/src/parameterizations/vertical/MOM_tidal_mixing.F90 index 27b316e144..a788a964f6 100644 --- a/src/parameterizations/vertical/MOM_tidal_mixing.F90 +++ b/src/parameterizations/vertical/MOM_tidal_mixing.F90 @@ -590,7 +590,7 @@ logical function tidal_mixing_init(Time, G, GV, US, param_file, diag, CS) if (CS%use_CVMix_tidal) then CS%id_N2_int = register_diag_field('ocean_model','N2_int',diag%axesTi,Time, & - 'Bouyancy frequency squared, at interfaces', 's-2') !###, conversion=US%s_to_T**2) + 'Bouyancy frequency squared, at interfaces', 's-2', conversion=US%s_to_T**2) !> TODO: add units CS%id_Simmons_coeff = register_diag_field('ocean_model','Simmons_coeff',diag%axesT1,Time, & 'time-invariant portion of the tidal mixing coefficient using the Simmons', '') From a041a95f1c9d33409c822802f4e3978603e70705 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 7 May 2020 08:04:44 -0400 Subject: [PATCH 258/316] (*)Corrected loop bounds in build_adapt_column Corrected the upper loop bound in a call to calculate_density_derivs in build_adapt_column. This code is not yet tested, so all answers are bitwise identical in the MOM6-examples test cases. --- src/ALE/coord_adapt.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/ALE/coord_adapt.F90 b/src/ALE/coord_adapt.F90 index 42ae0ee245..8fa4b09fc5 100644 --- a/src/ALE/coord_adapt.F90 +++ b/src/ALE/coord_adapt.F90 @@ -209,7 +209,7 @@ subroutine build_adapt_column(CS, G, GV, US, tv, i, j, zInt, tInt, sInt, h, zNex ! a positive curvature means we're too light relative to adjacent columns, ! so del2sigma needs to be positive too (push the interface deeper) call calculate_density_derivs(tInt(i,j,:), sInt(i,j,:), zInt(i,j,:) * (GV%H_to_RZ * GV%g_Earth), & - alpha, beta, tv%eqn_of_state, (/1,nz/) ) !### This should be (/1,nz+1/) - see 25 lines below. + alpha, beta, tv%eqn_of_state, (/1,nz+1/) ) do K = 2, nz ! TODO make lower bound here configurable dh_d2s(K) = del2sigma(K) * (0.5 * (h(i,j,k-1) + h(i,j,k))) / & From 3e28d61258712e66cdc3b3dd2ae20c007c392dfa Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 7 May 2020 08:05:26 -0400 Subject: [PATCH 259/316] Corrected rescaling with CONST_SEA_LEVEL Corrected parentheses in calculating the balancing_flux with an ice-shelf. This corrects the dimensional rescaling with the CONST_SEA_LEVEL option within the ice-shelf code, but does not change answers in any MOM6-examples test cases. --- src/ice_shelf/MOM_ice_shelf.F90 | 9 ++++----- 1 file changed, 4 insertions(+), 5 deletions(-) diff --git a/src/ice_shelf/MOM_ice_shelf.F90 b/src/ice_shelf/MOM_ice_shelf.F90 index 891d6b3ea7..026745ee91 100644 --- a/src/ice_shelf/MOM_ice_shelf.F90 +++ b/src/ice_shelf/MOM_ice_shelf.F90 @@ -1051,10 +1051,10 @@ subroutine add_shelf_flux(G, US, CS, sfc_state, fluxes) enddo ; enddo balancing_area = global_area_integral(bal_frac, G) - if (balancing_area > 0.0) then !### Examine whether the rescaling should be inside the parenthesis. - balancing_flux = US%kg_m2s_to_RZ_T*(global_area_integral(ISS%water_flux, G, scale=US%RZ_T_to_kg_m2s, & - area=ISS%area_shelf_h) + & - delta_mass_shelf ) / balancing_area + if (balancing_area > 0.0) then + balancing_flux = ( US%kg_m2s_to_RZ_T*global_area_integral(ISS%water_flux, G, scale=US%RZ_T_to_kg_m2s, & + area=ISS%area_shelf_h) + & + delta_mass_shelf ) / balancing_area else balancing_flux = 0.0 endif @@ -1166,7 +1166,6 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl write(0,*) 'IG: ', G%isd, G%isc, G%iec, G%ied, G%jsd, G%jsc, G%jsd, G%jed endif - CS%Time = Time ! ### This might not be in the right place? CS%diag => diag ! Are we being called from the solo ice-sheet driver? When called by the ocean From b7e37761f588493af21b3f47f76cb0b1f25d624e Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 7 May 2020 08:12:01 -0400 Subject: [PATCH 260/316] (*)Fix dimensional inconsistency in calc_CVMix_shear Corrected a dimensionally inconsistent expression in the thickness that determines when a layer has vanished in calculate_CVMix_shear. This would change answers for some ranges of dimensional rescaling or for non-Boussinesq configurations using the CVMix shear code. All answers in the MOM6-examples test cases are bitwise identical. --- src/parameterizations/vertical/MOM_CVMix_shear.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/parameterizations/vertical/MOM_CVMix_shear.F90 b/src/parameterizations/vertical/MOM_CVMix_shear.F90 index 6f1a629ab4..f099305f0c 100644 --- a/src/parameterizations/vertical/MOM_CVMix_shear.F90 +++ b/src/parameterizations/vertical/MOM_CVMix_shear.F90 @@ -88,10 +88,11 @@ subroutine calculate_CVMix_shear(u_H, v_H, h, tv, kd, kv, G, GV, US, CS ) real, dimension(G%ke+1) :: Ri_Grad !< Gradient Richardson number [nondim] real, dimension(G%ke+1) :: Kvisc !< Vertical viscosity at interfaces [m2 s-1] real, dimension(G%ke+1) :: Kdiff !< Diapycnal diffusivity at interfaces [m2 s-1] - real, parameter :: epsln = 1.e-10 !< Threshold to identify vanished layers [m] + real :: epsln !< Threshold to identify vanished layers [H ~> m or kg m-2] ! some constants GoRho = US%L_to_Z**2 * GV%g_Earth / GV%Rho0 + epsln = 1.e-10 * GV%m_to_H do j = G%jsc, G%jec do i = G%isc, G%iec @@ -148,7 +149,6 @@ subroutine calculate_CVMix_shear(u_H, v_H, h, tv, kd, kv, G, GV, US, CS ) if (CS%smooth_ri) then ! 1) fill Ri_grad in vanished layers with adjacent value - !### For dimensional consistency, epsln needs to be epsln*GV%m_to_H. do k = 2, G%ke if (h(i,j,k) <= epsln) Ri_grad(k) = Ri_grad(k-1) enddo From 450e954a7dd243500586d8a944fad5971c2fe019 Mon Sep 17 00:00:00 2001 From: Raphael Dussin Date: Thu, 7 May 2020 09:30:12 -0400 Subject: [PATCH 261/316] fix out of bounds when nrows == 1 --- src/diagnostics/MOM_wave_speed.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/diagnostics/MOM_wave_speed.F90 b/src/diagnostics/MOM_wave_speed.F90 index 65a23e0fa2..9da2963c16 100644 --- a/src/diagnostics/MOM_wave_speed.F90 +++ b/src/diagnostics/MOM_wave_speed.F90 @@ -1246,7 +1246,7 @@ subroutine tridiag_det(a, b, c, nrows, lam, det_out, ddet_out, row_scale) rscl = 1.0 ; if (present(row_scale)) rscl = row_scale det(1) = 1.0 ; ddet(1) = 0.0 - det(2) = b(2)-lam ; ddet(2) = -1.0 + if (nrows > 1) then ; det(2) = b(2)-lam ; ddet(2) = -1.0 ; endif do n=3,nrows det(n) = rscl*(b(n)-lam)*det(n-1) - rscl*(a(n)*c(n-1))*det(n-2) ddet(n) = rscl*(b(n)-lam)*ddet(n-1) - rscl*(a(n)*c(n-1))*ddet(n-2) - det(n-1) From e16d7ece85be1a5a47789f4bfbd1d5a25653ec01 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 7 May 2020 12:54:46 -0400 Subject: [PATCH 262/316] Reduced the halo size in an update for eta Reduced the halo size for an update to eta to 1. There had been a note in the code suggesting that this should be possible for the past 3 years, but that for unknown reasons this changed the answers with the circle_OBCs test case. At some point whatever problems with the OBCs that caused this unexpected dependency on overly large halos has been corrected, and this halo update can now use its expected size of 1. All answers are bitwise identical. --- src/core/MOM_dynamics_split_RK2.F90 | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/src/core/MOM_dynamics_split_RK2.F90 b/src/core/MOM_dynamics_split_RK2.F90 index 2517846b4c..5a20e60b04 100644 --- a/src/core/MOM_dynamics_split_RK2.F90 +++ b/src/core/MOM_dynamics_split_RK2.F90 @@ -388,10 +388,8 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, Time_local, dt, forces, p_s !--- begin set up for group halo pass cont_stencil = continuity_stencil(CS%continuity_CSp) - !### Apart from circle_OBCs halo for eta could be 1, but halo>=3 is required - !### to match circle_OBCs solutions. Why? call cpu_clock_begin(id_clock_pass) - call create_group_pass(CS%pass_eta, eta, G%Domain) !### , halo=1) + call create_group_pass(CS%pass_eta, eta, G%Domain, halo=1) call create_group_pass(CS%pass_visc_rem, CS%visc_rem_u, CS%visc_rem_v, G%Domain, & To_All+SCALAR_PAIR, CGRID_NE, halo=max(1,cont_stencil)) call create_group_pass(CS%pass_uvp, up, vp, G%Domain, halo=max(1,cont_stencil)) From ce3df026e6c50741f5f67aa2401f2ba7535e9a92 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 7 May 2020 15:42:51 -0400 Subject: [PATCH 263/316] +Optionally correct timesteps in unsplit viscosity Added the option to correct the timesteps used for the first predictor step viscosity and the surface boundary layer viscosities with the unsplit time stepping. This includes adding the runtime parameter FIX_UNSPLIT_DT_VISC_BUG, which leads to changes in the MOM_parameter_doc files when SPLIT=False and USE_RK2=False. Several unneeded line continuations were removed. By default, all answers are bitwise identical. --- src/core/MOM_dynamics_unsplit.F90 | 56 +++++++++++++-------------- src/core/MOM_dynamics_unsplit_RK2.F90 | 3 +- 2 files changed, 30 insertions(+), 29 deletions(-) diff --git a/src/core/MOM_dynamics_unsplit.F90 b/src/core/MOM_dynamics_unsplit.F90 index 8c6e7d4299..25b25d5667 100644 --- a/src/core/MOM_dynamics_unsplit.F90 +++ b/src/core/MOM_dynamics_unsplit.F90 @@ -120,6 +120,10 @@ module MOM_dynamics_unsplit real, pointer, dimension(:,:) :: tauy_bot => NULL() !< frictional y-bottom stress from the ocean !! to the seafloor [R L Z T-2 ~> Pa] + logical :: use_correct_dt_visc ! If true, use the correct timestep in the viscous terms applied + ! in the first predictor step with the unsplit time stepping scheme, + ! and in the calculation of the turbulent mixed layer properties + ! for viscosity. The default should be true, but it is false. logical :: debug !< If true, write verbose checksums for debugging purposes. logical :: module_is_initialized = .false. !< Record whether this mouled has been initialzed. @@ -228,6 +232,7 @@ subroutine step_MOM_dyn_unsplit(u, v, h, tv, visc, Time_local, dt, forces, & real, dimension(SZI_(G),SZJB_(G),SZK_(G)) :: vp, vpp ! Predicted meridional velocities [L T-1 ~> m s-1] real, dimension(:,:), pointer :: p_surf => NULL() real :: dt_pred ! The time step for the predictor part of the baroclinic time stepping [T ~> s]. + real :: dt_visc ! The time step for a part of the update due to viscosity [T ~> s]. logical :: dyn_p_surf integer :: i, j, k, is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke @@ -255,8 +260,7 @@ subroutine step_MOM_dyn_unsplit(u, v, h, tv, visc, Time_local, dt, forces, & ! diffu = horizontal viscosity terms (u,h) call enable_averages(dt, Time_local, CS%diag) call cpu_clock_begin(id_clock_horvisc) - call horizontal_viscosity(u, v, h, CS%diffu, CS%diffv, MEKE, Varmix, & - G, GV, US, CS%hor_visc_CSp) + call horizontal_viscosity(u, v, h, CS%diffu, CS%diffv, MEKE, Varmix, G, GV, US, CS%hor_visc_CSp) call cpu_clock_end(id_clock_horvisc) call disable_averaging(CS%diag) @@ -323,31 +327,29 @@ subroutine step_MOM_dyn_unsplit(u, v, h, tv, visc, Time_local, dt, forces, & ! up = u + dt_pred * (PFu + CAu) call cpu_clock_begin(id_clock_mom_update) do k=1,nz ; do j=js,je ; do I=Isq,Ieq - up(I,j,k) = G%mask2dCu(I,j) * (u(I,j,k) + dt_pred * & - (CS%PFu(I,j,k) + CS%CAu(I,j,k))) + up(I,j,k) = G%mask2dCu(I,j) * (u(I,j,k) + dt_pred * (CS%PFu(I,j,k) + CS%CAu(I,j,k))) enddo ; enddo ; enddo do k=1,nz ; do J=Jsq,Jeq ; do i=is,ie - vp(i,J,k) = G%mask2dCv(i,J) * (v(i,J,k) + dt_pred * & - (CS%PFv(i,J,k) + CS%CAv(i,J,k))) + vp(i,J,k) = G%mask2dCv(i,J) * (v(i,J,k) + dt_pred * (CS%PFv(i,J,k) + CS%CAv(i,J,k))) enddo ; enddo ; enddo call cpu_clock_end(id_clock_mom_update) if (CS%debug) then call MOM_state_chksum("Predictor 1", up, vp, h_av, uh, vh, G, GV, US) - call MOM_accel_chksum("Predictor 1 accel", CS%CAu, CS%CAv, CS%PFu, CS%PFv,& + call MOM_accel_chksum("Predictor 1 accel", CS%CAu, CS%CAv, CS%PFu, CS%PFv, & CS%diffu, CS%diffv, G, GV, US) endif ! up <- up + dt/2 d/dz visc d/dz up call cpu_clock_begin(id_clock_vertvisc) call enable_averages(dt, Time_local, CS%diag) - call set_viscous_ML(u, v, h_av, tv, forces, visc, dt*0.5, G, GV, US, & - CS%set_visc_CSp) + dt_visc = 0.5*dt ; if (CS%use_correct_dt_visc) dt_visc = dt + call set_viscous_ML(u, v, h_av, tv, forces, visc, dt_visc, G, GV, US, CS%set_visc_CSp) call disable_averaging(CS%diag) - !### I think that the time steps in the next two calls should be dt_pred. - call vertvisc_coef(up, vp, h_av, forces, visc, dt*0.5, G, GV, US, & - CS%vertvisc_CSp, CS%OBC) - call vertvisc(up, vp, h_av, forces, visc, dt*0.5, CS%OBC, CS%ADp, CS%CDp, & + + dt_visc = 0.5*dt ; if (CS%use_correct_dt_visc) dt_visc = dt_pred + call vertvisc_coef(up, vp, h_av, forces, visc, dt_visc, G, GV, US, CS%vertvisc_CSp, CS%OBC) + call vertvisc(up, vp, h_av, forces, visc, dt_visc, CS%OBC, CS%ADp, CS%CDp, & G, GV, US, CS%vertvisc_CSp, Waves=Waves) call cpu_clock_end(id_clock_vertvisc) call pass_vector(up, vp, G%Domain, clock=id_clock_pass) @@ -355,8 +357,7 @@ subroutine step_MOM_dyn_unsplit(u, v, h, tv, visc, Time_local, dt, forces, & ! uh = up * hp ! h_av = hp + dt/2 div . uh call cpu_clock_begin(id_clock_continuity) - call continuity(up, vp, hp, h_av, uh, vh, (0.5*dt), G, GV, US, & - CS%continuity_CSp, OBC=CS%OBC) + call continuity(up, vp, hp, h_av, uh, vh, (0.5*dt), G, GV, US, CS%continuity_CSp, OBC=CS%OBC) call cpu_clock_end(id_clock_continuity) call pass_var(h_av, G%Domain, clock=id_clock_pass) call pass_vector(uh, vh, G%Domain, clock=id_clock_pass) @@ -392,25 +393,22 @@ subroutine step_MOM_dyn_unsplit(u, v, h, tv, visc, Time_local, dt, forces, & ! upp = u + dt/2 * ( PFu + CAu ) call cpu_clock_begin(id_clock_mom_update) do k=1,nz ; do j=js,je ; do I=Isq,Ieq - upp(I,j,k) = G%mask2dCu(I,j) * (u(I,j,k) + dt * 0.5 * & - (CS%PFu(I,j,k) + CS%CAu(I,j,k))) + upp(I,j,k) = G%mask2dCu(I,j) * (u(I,j,k) + dt * 0.5 * (CS%PFu(I,j,k) + CS%CAu(I,j,k))) enddo ; enddo ; enddo do k=1,nz ; do J=Jsq,Jeq ; do i=is,ie - vpp(i,J,k) = G%mask2dCv(i,J) * (v(i,J,k) + dt * 0.5 * & - (CS%PFv(i,J,k) + CS%CAv(i,J,k))) + vpp(i,J,k) = G%mask2dCv(i,J) * (v(i,J,k) + dt * 0.5 * (CS%PFv(i,J,k) + CS%CAv(i,J,k))) enddo ; enddo ; enddo call cpu_clock_end(id_clock_mom_update) if (CS%debug) then call MOM_state_chksum("Predictor 2", upp, vpp, h_av, uh, vh, G, GV, US) - call MOM_accel_chksum("Predictor 2 accel", CS%CAu, CS%CAv, CS%PFu, CS%PFv,& + call MOM_accel_chksum("Predictor 2 accel", CS%CAu, CS%CAv, CS%PFu, CS%PFv, & CS%diffu, CS%diffv, G, GV, US) endif ! upp <- upp + dt/2 d/dz visc d/dz upp call cpu_clock_begin(id_clock_vertvisc) - call vertvisc_coef(upp, vpp, hp, forces, visc, dt*0.5, G, GV, US, & - CS%vertvisc_CSp, CS%OBC) + call vertvisc_coef(upp, vpp, hp, forces, visc, dt*0.5, G, GV, US, CS%vertvisc_CSp, CS%OBC) call vertvisc(upp, vpp, hp, forces, visc, dt*0.5, CS%OBC, CS%ADp, CS%CDp, & G, GV, US, CS%vertvisc_CSp, Waves=Waves) call cpu_clock_end(id_clock_vertvisc) @@ -419,8 +417,7 @@ subroutine step_MOM_dyn_unsplit(u, v, h, tv, visc, Time_local, dt, forces, & ! uh = upp * hp ! h = hp + dt/2 div . uh call cpu_clock_begin(id_clock_continuity) - call continuity(upp, vpp, hp, h, uh, vh, (dt*0.5), G, GV, US, & - CS%continuity_CSp, OBC=CS%OBC) + call continuity(upp, vpp, hp, h, uh, vh, (dt*0.5), G, GV, US, CS%continuity_CSp, OBC=CS%OBC) call cpu_clock_end(id_clock_continuity) call pass_var(h, G%Domain, clock=id_clock_pass) call pass_vector(uh, vh, G%Domain, clock=id_clock_pass) @@ -470,12 +467,10 @@ subroutine step_MOM_dyn_unsplit(u, v, h, tv, visc, Time_local, dt, forces, & call open_boundary_zero_normal_flow(CS%OBC, G, CS%CAu, CS%CAv) endif do k=1,nz ; do j=js,je ; do I=Isq,Ieq - u(I,j,k) = G%mask2dCu(I,j) * (u(I,j,k) + dt * & - (CS%PFu(I,j,k) + CS%CAu(I,j,k))) + u(I,j,k) = G%mask2dCu(I,j) * (u(I,j,k) + dt * (CS%PFu(I,j,k) + CS%CAu(I,j,k))) enddo ; enddo ; enddo do k=1,nz ; do J=Jsq,Jeq ; do i=is,ie - v(i,J,k) = G%mask2dCv(i,J) * (v(i,J,k) + dt * & - (CS%PFv(i,J,k) + CS%CAv(i,J,k))) + v(i,J,k) = G%mask2dCv(i,J) * (v(i,J,k) + dt * (CS%PFv(i,J,k) + CS%CAv(i,J,k))) enddo ; enddo ; enddo ! u <- u + dt d/dz visc d/dz u @@ -639,6 +634,11 @@ subroutine initialize_dyn_unsplit(u, v, h, Time, G, GV, US, param_file, diag, CS default=.false., debuggingParam=.true.) call get_param(param_file, mdl, "TIDES", use_tides, & "If true, apply tidal momentum forcing.", default=.false.) + call get_param(param_file, mdl, "FIX_UNSPLIT_DT_VISC_BUG", CS%use_correct_dt_visc, & + "If true, use the correct timestep in the viscous terms applied in the first "//& + "predictor step with the unsplit time stepping scheme, and in the calculation "//& + "of the turbulent mixed layer properties for viscosity. "//& + "The default should be true.", default=.false.) allocate(CS%taux_bot(IsdB:IedB,jsd:jed)) ; CS%taux_bot(:,:) = 0.0 allocate(CS%tauy_bot(isd:ied,JsdB:JedB)) ; CS%tauy_bot(:,:) = 0.0 diff --git a/src/core/MOM_dynamics_unsplit_RK2.F90 b/src/core/MOM_dynamics_unsplit_RK2.F90 index d3adfaa194..085611c51b 100644 --- a/src/core/MOM_dynamics_unsplit_RK2.F90 +++ b/src/core/MOM_dynamics_unsplit_RK2.F90 @@ -339,9 +339,10 @@ subroutine step_MOM_dyn_unsplit_RK2(u_in, v_in, h_in, tv, visc, Time_local, dt, ! up[n-1/2] <- up*[n-1/2] + dt/2 d/dz visc d/dz up[n-1/2] call cpu_clock_begin(id_clock_vertvisc) call enable_averages(dt, Time_local, CS%diag) - call set_viscous_ML(up, vp, h_av, tv, forces, visc, dt_pred, G, GV, US, & + call set_viscous_ML(up, vp, h_av, tv, forces, visc, dt, G, GV, US, & CS%set_visc_CSp) call disable_averaging(CS%diag) + call vertvisc_coef(up, vp, h_av, forces, visc, dt_pred, G, GV, US, & CS%vertvisc_CSp, CS%OBC) call vertvisc(up, vp, h_av, forces, visc, dt_pred, CS%OBC, CS%ADp, CS%CDp, & From c39ab9e4c2eed6e1a5e68366e9196598def69b0e Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 7 May 2020 15:53:40 -0400 Subject: [PATCH 264/316] +Use time types to manage offline tracers Revised the offline tracer code to use time types to manage the offline tracer time stepping. There is a new optional argument to step_offline. The offline tracers are not adequately tested, but the code compiles and the logic should be correct. All answers in the MOM6-examples test cases are bitwise identical. --- src/core/MOM.F90 | 27 +++++++++++++++------------ src/tracer/MOM_offline_main.F90 | 18 +++++++++++------- 2 files changed, 26 insertions(+), 19 deletions(-) diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index aff4860a21..1553ff7e1a 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -45,7 +45,7 @@ module MOM use MOM_spatial_means, only : global_mass_integral use MOM_time_manager, only : time_type, real_to_time, time_type_to_real, operator(+) use MOM_time_manager, only : operator(-), operator(>), operator(*), operator(/) -use MOM_time_manager, only : operator(>=), increment_date +use MOM_time_manager, only : operator(>=), 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 @@ -1404,7 +1404,8 @@ subroutine step_offline(forces, fluxes, sfc_state, Time_start, time_interval, CS logical :: skip_diffusion integer :: id_eta_diff_end - integer, pointer :: accumulated_time => NULL() + type(time_type), pointer :: accumulated_time => NULL() + type(time_type), pointer :: vertical_time => NULL() integer :: i,j,k integer :: is, ie, js, je, isd, ied, jsd, jed @@ -1426,32 +1427,30 @@ subroutine step_offline(forces, fluxes, sfc_state, Time_start, time_interval, CS call cpu_clock_begin(id_clock_offline_tracer) call extract_offline_main(CS%offline_CSp, uhtr, vhtr, eatr, ebtr, h_end, accumulated_time, & - dt_offline, dt_offline_vertical, skip_diffusion) + vertical_time, dt_offline, dt_offline_vertical, skip_diffusion) Time_end = increment_date(Time_start, seconds=floor(time_interval+0.001)) 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 == real_to_time(0.0)) then first_iter = .true. else ! This is probably unnecessary but is used to guard against unwanted behavior first_iter = .false. endif - ! Check to see if vertical tracer functions should be done - if ( mod(accumulated_time, floor(US%T_to_s*dt_offline_vertical + 1e-6)) == 0 ) then + ! Check to see if vertical tracer functions should be done + if (first_iter .or. (accumulated_time >= vertical_time)) then do_vertical = .true. + vertical_time = accumulated_time + real_to_time(US%T_to_s*dt_offline_vertical) else do_vertical = .false. endif ! 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), floor(US%T_to_s*dt_offline+1e-6)) - if (accumulated_time==0) then - last_iter = .true. - else - last_iter = .false. - endif + accumulated_time = accumulated_time + real_to_time(time_interval) + + last_iter = (accumulated_time >= real_to_time(US%T_to_s*dt_offline)) if (CS%use_ALE_algorithm) then ! If this is the first iteration in the offline timestep, then we need to read in fields and @@ -1566,6 +1565,10 @@ subroutine step_offline(forces, fluxes, sfc_state, Time_start, time_interval, CS fluxes%fluxes_used = .true. + if (last_iter) then + accumulated_time = real_to_time(0.0) + endif + call cpu_clock_end(id_clock_offline_tracer) end subroutine step_offline diff --git a/src/tracer/MOM_offline_main.F90 b/src/tracer/MOM_offline_main.F90 index 65f83ecfea..c0ee07d434 100644 --- a/src/tracer/MOM_offline_main.F90 +++ b/src/tracer/MOM_offline_main.F90 @@ -28,7 +28,7 @@ module MOM_offline_main use MOM_offline_aux, only : distribute_residual_uh_upwards, distribute_residual_vh_upwards use MOM_opacity, only : opacity_CS, optics_type use MOM_open_boundary, only : ocean_OBC_type -use MOM_time_manager, only : time_type +use MOM_time_manager, only : time_type, real_to_time use MOM_tracer_advect, only : tracer_advect_CS, advect_tracer use MOM_tracer_diabatic, only : applyTracerBoundaryFluxesInOut use MOM_tracer_flow_control, only : tracer_flow_control_CS, call_tracer_column_fns, call_tracer_stocks @@ -79,7 +79,8 @@ module MOM_offline_main integer :: start_index !< Timelevel to start integer :: iter_no !< Timelevel to start integer :: numtime !< How many timelevels in the input fields - integer :: accumulated_time !< Length of time accumulated in the current offline interval + type(time_type) :: accumulated_time !< Length of time accumulated in the current offline interval + type(time_type) :: vertical_time !< The next value of accumulate_time at which to apply vertical processes ! Index of each of the variables to be read in with separate indices for each variable if they ! are set off from each other in time integer :: ridx_sum = -1 !< Read index offset of the summed variables @@ -1200,7 +1201,7 @@ 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, & +subroutine extract_offline_main(CS, uhtr, vhtr, eatr, ebtr, h_end, accumulated_time, vertical_time, & dt_offline, dt_offline_vertical, skip_diffusion) type(offline_transport_CS), target, intent(in ) :: CS !< Offline control structure ! Returned optional arguments @@ -1212,9 +1213,10 @@ subroutine extract_offline_main(CS, uhtr, vhtr, eatr, ebtr, h_end, accumulated_t !! one time step [H ~> m or kg m-2] real, dimension(:,:,:), optional, pointer :: h_end !< Thicknesses at the end of offline timestep !! [H ~> m or kg m-2] - !### Why are the following variables integers? - integer, optional, pointer :: accumulated_time !< Length of time accumulated in the - !! current offline interval [s] + type(time_type), optional, pointer :: accumulated_time !< Length of time accumulated in the + !! current offline interval + type(time_type), optional, pointer :: vertical_time !< The next value of accumulate_time at which to + !! vertical processes real, optional, intent( out) :: dt_offline !< Timestep used for offline tracers [T ~> s] real, optional, intent( out) :: dt_offline_vertical !< Timestep used for calls to tracer !! vertical physics [T ~> s] @@ -1229,6 +1231,7 @@ subroutine extract_offline_main(CS, uhtr, vhtr, eatr, ebtr, h_end, accumulated_t ! Pointers to integer members which need to be modified if (present(accumulated_time)) accumulated_time => CS%accumulated_time + if (present(vertical_time)) vertical_time => CS%vertical_time ! Return value of non-modified integers if (present(dt_offline)) dt_offline = CS%dt_offline @@ -1414,7 +1417,8 @@ subroutine offline_transport_init(param_file, CS, diabatic_CSp, G, GV, US) end select ! Set the accumulated time to zero - CS%accumulated_time = 0 + CS%accumulated_time = real_to_time(0.0) + CS%vertical_time = CS%accumulated_time ! Set the starting read index for time-averaged and snapshotted fields CS%ridx_sum = CS%start_index if (CS%fields_are_offset) CS%ridx_snap = next_modulo_time(CS%start_index,CS%numtime) From ea17a977f7c7935c753a483b6f24c7bbdb6fcdd4 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 7 May 2020 19:08:30 -0400 Subject: [PATCH 265/316] Corrected units in comments in coord_rho Corrected or added the units of variables in the coord_rho module. All answers are bitwise identical. --- src/ALE/MOM_regridding.F90 | 2 +- src/ALE/coord_rho.F90 | 4 ++-- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/src/ALE/MOM_regridding.F90 b/src/ALE/MOM_regridding.F90 index 9bc71dd15f..ed6e66e0ae 100644 --- a/src/ALE/MOM_regridding.F90 +++ b/src/ALE/MOM_regridding.F90 @@ -1353,7 +1353,7 @@ subroutine build_rho_grid( G, GV, US, h, tv, dzInterface, remapCS, CS ) integer :: nz integer :: i, j, k real :: nominalDepth ! Depth of the bottom of the ocean, positive downward [H ~> m or kg m-2] - real, dimension(SZK_(GV)+1) :: zOld, zNew + real, dimension(SZK_(GV)+1) :: zOld, zNew ! Old and new interface heights [H ~> m or kg m-2] real :: h_neglect, h_neglect_edge ! Negligible thicknesses [H ~> m or kg m-2] #ifdef __DO_SAFETY_CHECKS__ real :: totalThickness diff --git a/src/ALE/coord_rho.F90 b/src/ALE/coord_rho.F90 index 5299c74b1b..dce802ff3c 100644 --- a/src/ALE/coord_rho.F90 +++ b/src/ALE/coord_rho.F90 @@ -91,7 +91,7 @@ subroutine build_rho_column(CS, nz, depth, h, T, S, eqn_of_state, z_interface, & h_neglect, h_neglect_edge) type(rho_CS), intent(in) :: CS !< coord_rho control structure integer, intent(in) :: nz !< Number of levels on source grid (i.e. length of h, T, S) - real, intent(in) :: depth !< Depth of ocean bottom (positive in m) + real, intent(in) :: depth !< Depth of ocean bottom (positive downward) [H ~> m or kg m-2] real, dimension(nz), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] real, dimension(nz), intent(in) :: T !< Temperature for source column [degC] real, dimension(nz), intent(in) :: S !< Salinity for source column [ppt] @@ -111,7 +111,7 @@ subroutine build_rho_column(CS, nz, depth, h, T, S, eqn_of_state, z_interface, & real, dimension(nz) :: densities ! Layer density [R ~> kg m-3] real, dimension(nz+1) :: xTmp ! Temporary positions [H ~> m or kg m-2] real, dimension(CS%nk) :: h_new ! New thicknesses [H ~> m or kg m-2] - real, dimension(CS%nk+1) :: x1 + real, dimension(CS%nk+1) :: x1 ! Interface heights [H ~> m or kg m-2] ! Construct source column with vanished layers removed (stored in h_nv) call copy_finite_thicknesses(nz, h, CS%min_thickness, count_nonzero_layers, h_nv, mapping) From 0d983b57934faaaa1dc71f67cb5ac0184e203089 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 7 May 2020 19:11:32 -0400 Subject: [PATCH 266/316] (*)Fixed dimensionally inconsistent diagnostic remap Corrected a dimensionally inconsistent statement when remapping diagnostics to rho-space. The ocean bottom depth had been passed in [m] but should have been passed in [H], which could change diagnostics for non-Boussinesq models. Also added multiple comments documenting the units of variables in MOM_regridding. All solutions are bitwise identical, but some rho-space diagnostics could change, especially for non-Boussinesq models. --- src/framework/MOM_diag_remap.F90 | 101 +++++++++++++++---------------- 1 file changed, 50 insertions(+), 51 deletions(-) diff --git a/src/framework/MOM_diag_remap.F90 b/src/framework/MOM_diag_remap.F90 index 0fe937a173..4e12abaa5b 100644 --- a/src/framework/MOM_diag_remap.F90 +++ b/src/framework/MOM_diag_remap.F90 @@ -31,11 +31,11 @@ ! ! For interpolation between h and u grids, we use the following relations: ! -! h->u: f_u[ig] = 0.5 * (f_h[ ig ] + f_h[ig+1]) -! f_u[i1] = 0.5 * (f_h[i1-1] + f_h[ i1 ]) +! h->u: f_u(ig) = 0.5 * (f_h( ig ) + f_h(ig+1)) +! f_u(i1) = 0.5 * (f_h(i1-1) + f_h( i1 )) ! -! u->h: f_h[ig] = 0.5 * (f_u[ig-1] + f_u[ ig ]) -! f_h[i1] = 0.5 * (f_u[ i1 ] + f_u[i1+1]) +! u->h: f_h(ig) = 0.5 * (f_u(ig-1) + f_u( ig )) +! f_h(i1) = 0.5 * (f_u( i1 ) + f_u(i1+1)) ! ! where ig is the grid index and i1 is the 1-based index. That is, a 1-based ! u-point is ahead of its matching h-point in non-symmetric mode, but behind @@ -110,11 +110,11 @@ module MOM_diag_remap character(len=16) :: diag_coord_name = '' !< A name for the purpose of run-time parameters character(len=8) :: diag_module_suffix = '' !< The suffix for the module to appear in diag_table type(remapping_CS) :: remap_cs !< Remapping control structure use for this axes - type(regridding_CS) :: regrid_cs !< Regridding control structure that defines the coordiantes for this axes + type(regridding_CS) :: regrid_cs !< Regridding control structure that defines the coordinates for this axes integer :: nz = 0 !< Number of vertical levels used for remapping - real, dimension(:,:,:), allocatable :: h !< Remap grid thicknesses - real, dimension(:,:,:), allocatable :: h_extensive !< Remap grid thicknesses for extensive variables - real, dimension(:), allocatable :: dz !< Nominal layer thicknesses + real, dimension(:,:,:), allocatable :: h !< Remap grid thicknesses [H ~> m or kg m-2] + real, dimension(:,:,:), allocatable :: h_extensive !< Remap grid thicknesses for extensive + !! variables [H ~> m or kg m-2] integer :: interface_axes_id = 0 !< Vertical axes id for remapping at interfaces integer :: layer_axes_id = 0 !< Vertical axes id for remapping on layers logical :: answers_2018 !< If true, use the order of arithmetic and expressions for remapping @@ -151,7 +151,6 @@ subroutine diag_remap_end(remap_cs) type(diag_remap_ctrl), intent(inout) :: remap_cs !< Diag remapping control structure if (allocated(remap_cs%h)) deallocate(remap_cs%h) - if (allocated(remap_cs%dz)) deallocate(remap_cs%dz) remap_cs%configured = .false. remap_cs%initialized = .false. remap_cs%used = .false. @@ -274,15 +273,15 @@ function diag_remap_axes_configured(remap_cs) !! coordinates then technically we should also regenerate the !! target grid whenever T/S change. subroutine diag_remap_update(remap_cs, G, GV, US, h, T, S, eqn_of_state, h_target) - type(diag_remap_ctrl), intent(inout) :: remap_cs !< Diagnostic coordinate control structure - type(ocean_grid_type), pointer :: G !< The ocean's grid type - type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - real, dimension(:, :, :), intent(in) :: h !< New thickness [H ~> m or kg m-2] - real, dimension(:, :, :), intent(in) :: T !< New temperatures [degC] - real, dimension(:, :, :), intent(in) :: S !< New salinities [ppt] - type(EOS_type), pointer :: eqn_of_state !< A pointer to the equation of state - real, dimension(:, :, :), intent(inout) :: h_target !< Where to store the new diagnostic array + type(diag_remap_ctrl), intent(inout) :: remap_cs !< Diagnostic coordinate control structure + type(ocean_grid_type), pointer :: G !< The ocean's grid type + type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(:,:,:), intent(in) :: h !< New thickness [H ~> m or kg m-2] + real, dimension(:,:,:), intent(in) :: T !< New temperatures [degC] + real, dimension(:,:,:), intent(in) :: S !< New salinities [ppt] + type(EOS_type), pointer :: eqn_of_state !< A pointer to the equation of state + real, dimension(:,:,:), intent(inout) :: h_target !< The new diagnostic thicknesses [H ~> m or kg m-2] ! Local variables real, dimension(remap_cs%nz + 1) :: zInterfaces ! Interface positions [H ~> m or kg m-2] @@ -328,9 +327,8 @@ subroutine diag_remap_update(remap_cs, G, GV, US, h, T, S, eqn_of_state, h_targe call build_sigma_column(get_sigma_CS(remap_cs%regrid_cs), & GV%Z_to_H*G%bathyT(i,j), sum(h(i,j,:)), zInterfaces) elseif (remap_cs%vertical_coord == coordinateMode('RHO')) then -!### I think that the conversion factor in the 2nd line should be GV%Z_to_H call build_rho_column(get_rho_CS(remap_cs%regrid_cs), G%ke, & - US%Z_to_m*G%bathyT(i,j), h(i,j,:), T(i,j,:), S(i,j,:), & + GV%Z_to_H*G%bathyT(i,j), h(i,j,:), T(i,j,:), S(i,j,:), & eqn_of_state, zInterfaces, h_neglect, h_neglect_edge) elseif (remap_cs%vertical_coord == coordinateMode('SLIGHT')) then ! call build_slight_column(remap_cs%regrid_cs,remap_cs%remap_cs, nz, & @@ -354,16 +352,16 @@ subroutine diag_remap_do_remap(remap_cs, G, GV, h, staggered_in_x, staggered_in_ type(diag_remap_ctrl), intent(in) :: remap_cs !< Diagnostic coodinate control structure type(ocean_grid_type), intent(in) :: G !< Ocean grid structure type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure - real, dimension(:,:,:), intent(in) :: h !< The current thicknesses + real, dimension(:,:,:), intent(in) :: h !< The current thicknesses [H ~> m or kg m-2] logical, intent(in) :: staggered_in_x !< True is the x-axis location is at u or q points logical, intent(in) :: staggered_in_y !< True is the y-axis location is at v or q points - real, dimension(:,:,:), pointer :: mask !< A mask for the field - real, dimension(:,:,:), intent(in) :: field(:,:,:) !< The diagnostic field to be remapped - real, dimension(:,:,:), intent(inout) :: remapped_field !< Field remapped to new coordinate + real, dimension(:,:,:), pointer :: mask !< A mask for the field [nondim] + real, dimension(:,:,:), intent(in) :: field(:,:,:) !< The diagnostic field to be remapped [A] + real, dimension(:,:,:), intent(inout) :: remapped_field !< Field remapped to new coordinate [A] ! Local variables - real, dimension(remap_cs%nz) :: h_dest - real, dimension(size(h,3)) :: h_src - real :: h_neglect, h_neglect_edge + real, dimension(remap_cs%nz) :: h_dest ! Destination thicknesses [H ~> m or kg m-2] + real, dimension(size(h,3)) :: h_src ! A column of source thicknesses [H ~> m or kg m-2] + real :: h_neglect, h_neglect_edge ! Negligible thicknesses [H ~> m or kg m-2] integer :: nz_src, nz_dest integer :: i, j, k !< Grid index integer :: i1, j1 !< 1-based index @@ -446,14 +444,15 @@ end subroutine diag_remap_do_remap !> Calculate masks for target grid subroutine diag_remap_calc_hmask(remap_cs, G, mask) - type(diag_remap_ctrl), intent(in) :: remap_cs !< Diagnostic coodinate control structure - type(ocean_grid_type), intent(in) :: G !< Ocean grid structure - real, dimension(:,:,:), intent(out) :: mask !< h-point mask for target grid + type(diag_remap_ctrl), intent(in) :: remap_cs !< Diagnostic coodinate control structure + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + real, dimension(:,:,:), intent(out) :: mask !< h-point mask for target grid [nondim] ! Local variables - real, dimension(remap_cs%nz) :: h_dest + real, dimension(remap_cs%nz) :: h_dest ! Destination thicknesses [H ~> m or kg m-2] integer :: i, j, k logical :: mask_vanished_layers - real :: h_tot, h_err + real :: h_tot ! Sum of all thicknesses [H ~> m or kg m-2] + real :: h_err ! An estimate of a negligible thickness [H ~> m or kg m-2] call assert(remap_cs%initialized, 'diag_remap_calc_hmask: remap_cs not initialized.') @@ -492,16 +491,16 @@ subroutine vertically_reintegrate_diag_field(remap_cs, G, h, h_target, staggered mask, field, reintegrated_field) type(diag_remap_ctrl), intent(in) :: remap_cs !< Diagnostic coodinate control structure type(ocean_grid_type), intent(in) :: G !< Ocean grid structure - real, dimension(:,:,:), intent(in) :: h !< The thicknesses of the source grid - real, dimension(:,:,:), intent(in) :: h_target !< The thicknesses of the target grid + real, dimension(:,:,:), intent(in) :: h !< The thicknesses of the source grid [H ~> m or kg m-2] + real, dimension(:,:,:), intent(in) :: h_target !< The thicknesses of the target grid [H ~> m or kg m-2] logical, intent(in) :: staggered_in_x !< True is the x-axis location is at u or q points logical, intent(in) :: staggered_in_y !< True is the y-axis location is at v or q points - real, dimension(:,:,:), pointer :: mask !< A mask for the field - real, dimension(:,:,:), intent(in) :: field !< The diagnostic field to be remapped - real, dimension(:,:,:), intent(inout) :: reintegrated_field !< Field argument remapped to alternative coordinate + real, dimension(:,:,:), pointer :: mask !< A mask for the field [nondim] + real, dimension(:,:,:), intent(in) :: field !< The diagnostic field to be remapped [A] + real, dimension(:,:,:), intent(inout) :: reintegrated_field !< Field argument remapped to alternative coordinate [A] ! Local variables - real, dimension(remap_cs%nz) :: h_dest - real, dimension(size(h,3)) :: h_src + real, dimension(remap_cs%nz) :: h_dest ! Destination thicknesses [H ~> m or kg m-2] + real, dimension(size(h,3)) :: h_src ! A column of source thicknesses [H ~> m or kg m-2] integer :: nz_src, nz_dest integer :: i, j, k !< Grid index integer :: i1, j1 !< 1-based index @@ -572,16 +571,16 @@ end subroutine vertically_reintegrate_diag_field subroutine vertically_interpolate_diag_field(remap_cs, G, h, staggered_in_x, staggered_in_y, & mask, field, interpolated_field) type(diag_remap_ctrl), intent(in) :: remap_cs !< Diagnostic coodinate control structure - type(ocean_grid_type), intent(in) :: G !< Ocean grid structure - real, dimension(:,:,:), intent(in) :: h !< The current thicknesses + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + real, dimension(:,:,:), intent(in) :: h !< The current thicknesses [H ~> m or kg m-2] logical, intent(in) :: staggered_in_x !< True is the x-axis location is at u or q points logical, intent(in) :: staggered_in_y !< True is the y-axis location is at v or q points - real, dimension(:,:,:), pointer :: mask !< A mask for the field - real, dimension(:,:,:), intent(in) :: field !< The diagnostic field to be remapped - real, dimension(:,:,:), intent(inout) :: interpolated_field !< Field argument remapped to alternative coordinate + real, dimension(:,:,:), pointer :: mask !< A mask for the field [nondim] + real, dimension(:,:,:), intent(in) :: field !< The diagnostic field to be remapped [A] + real, dimension(:,:,:), intent(inout) :: interpolated_field !< Field argument remapped to alternative coordinate [A] ! Local variables - real, dimension(remap_cs%nz) :: h_dest - real, dimension(size(h,3)) :: h_src + real, dimension(remap_cs%nz) :: h_dest ! Destination thicknesses [H ~> m or kg m-2] + real, dimension(size(h,3)) :: h_src ! A column of source thicknesses [H ~> m or kg m-2] integer :: nz_src, nz_dest integer :: i, j, k !< Grid index integer :: i1, j1 !< 1-based index @@ -656,20 +655,20 @@ subroutine horizontally_average_diag_field(G, GV, h, staggered_in_x, staggered_i averaged_mask) type(ocean_grid_type), intent(in) :: G !< Ocean grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean vertical grid structure - real, dimension(:,:,:), intent(in) :: h !< The current thicknesses + real, dimension(:,:,:), intent(in) :: h !< The current thicknesses [H ~> m or kg m-2] logical, intent(in) :: staggered_in_x !< True if the x-axis location is at u or q points logical, intent(in) :: staggered_in_y !< True if the y-axis location is at v or q points logical, intent(in) :: is_layer !< True if the z-axis location is at h points logical, intent(in) :: is_extensive !< True if the z-direction is spatially integrated (over layers) - real, dimension(:,:,:), intent(in) :: field !< The diagnostic field to be remapped - real, dimension(:), intent(inout) :: averaged_field !< Field argument horizontally averaged - logical, dimension(:), intent(inout) :: averaged_mask !< Mask for horizontally averaged field + real, dimension(:,:,:), intent(in) :: field !< The diagnostic field to be remapped [A] + real, dimension(:), intent(inout) :: averaged_field !< Field argument horizontally averaged [A] + logical, dimension(:), intent(inout) :: averaged_mask !< Mask for horizontally averaged field [nondim] ! Local variables real, dimension(G%isc:G%iec, G%jsc:G%jec, size(field,3)) :: volume, stuff real, dimension(size(field, 3)) :: vol_sum, stuff_sum ! nz+1 is needed for interface averages type(EFP_type), dimension(2*size(field,3)) :: sums_EFP ! Sums of volume or stuff by layer - real :: height + real :: height ! An average thickness attributed to an velocity point [H ~> m or kg m-2] integer :: i, j, k, nz integer :: i1, j1 !< 1-based index From 949b04ff88d07ffb11377d5265a72aa2acaaa9d9 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 7 May 2020 19:51:33 -0400 Subject: [PATCH 267/316] dOxygenized a comment in MOM_dyn_unsplit_CS --- src/core/MOM_dynamics_unsplit.F90 | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/core/MOM_dynamics_unsplit.F90 b/src/core/MOM_dynamics_unsplit.F90 index 25b25d5667..99cdc932e2 100644 --- a/src/core/MOM_dynamics_unsplit.F90 +++ b/src/core/MOM_dynamics_unsplit.F90 @@ -120,10 +120,10 @@ module MOM_dynamics_unsplit real, pointer, dimension(:,:) :: tauy_bot => NULL() !< frictional y-bottom stress from the ocean !! to the seafloor [R L Z T-2 ~> Pa] - logical :: use_correct_dt_visc ! If true, use the correct timestep in the viscous terms applied - ! in the first predictor step with the unsplit time stepping scheme, - ! and in the calculation of the turbulent mixed layer properties - ! for viscosity. The default should be true, but it is false. + logical :: use_correct_dt_visc !< If true, use the correct timestep in the viscous terms applied + !! in the first predictor step with the unsplit time stepping scheme, + !! and in the calculation of the turbulent mixed layer properties + !! for viscosity. The default should be true, but it is false. logical :: debug !< If true, write verbose checksums for debugging purposes. logical :: module_is_initialized = .false. !< Record whether this mouled has been initialzed. From 6ed79a43b2aef5af8138f336cc3ff72f1051a450 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 8 May 2020 07:15:47 -0400 Subject: [PATCH 268/316] +Added FIX_UNSPLIT_DT_VISC_BUG to unsplit_RK2 Add the runtime parameter FIX_UNSPLIT_DT_VISC_BUG to MOM_dynamics_unsplit_RK2 to preserve previous answers by default, analogously to what was done in a recent commit for MOM_dynamics_unsplit. Some unneeded line continuations were also removed for brevity. By default all answers are identical to those on the dev/gfdl branch. --- src/core/MOM_dynamics_unsplit.F90 | 10 ++++---- src/core/MOM_dynamics_unsplit_RK2.F90 | 36 ++++++++++++++------------- 2 files changed, 24 insertions(+), 22 deletions(-) diff --git a/src/core/MOM_dynamics_unsplit.F90 b/src/core/MOM_dynamics_unsplit.F90 index 99cdc932e2..d6a5186be3 100644 --- a/src/core/MOM_dynamics_unsplit.F90 +++ b/src/core/MOM_dynamics_unsplit.F90 @@ -629,16 +629,16 @@ subroutine initialize_dyn_unsplit(u, v, h, Time, G, GV, US, param_file, diag, CS CS%diag => diag + call get_param(param_file, mdl, "FIX_UNSPLIT_DT_VISC_BUG", CS%use_correct_dt_visc, & + "If true, use the correct timestep in the viscous terms applied in the first "//& + "predictor step with the unsplit time stepping scheme, and in the calculation "//& + "of the turbulent mixed layer properties for viscosity with unsplit or "//& + "unsplit_RK2. The default should be true.", default=.false.) call get_param(param_file, mdl, "DEBUG", CS%debug, & "If true, write out verbose debugging data.", & default=.false., debuggingParam=.true.) call get_param(param_file, mdl, "TIDES", use_tides, & "If true, apply tidal momentum forcing.", default=.false.) - call get_param(param_file, mdl, "FIX_UNSPLIT_DT_VISC_BUG", CS%use_correct_dt_visc, & - "If true, use the correct timestep in the viscous terms applied in the first "//& - "predictor step with the unsplit time stepping scheme, and in the calculation "//& - "of the turbulent mixed layer properties for viscosity. "//& - "The default should be true.", default=.false.) allocate(CS%taux_bot(IsdB:IedB,jsd:jed)) ; CS%taux_bot(:,:) = 0.0 allocate(CS%tauy_bot(isd:ied,JsdB:JedB)) ; CS%tauy_bot(:,:) = 0.0 diff --git a/src/core/MOM_dynamics_unsplit_RK2.F90 b/src/core/MOM_dynamics_unsplit_RK2.F90 index 085611c51b..e3ec48ff58 100644 --- a/src/core/MOM_dynamics_unsplit_RK2.F90 +++ b/src/core/MOM_dynamics_unsplit_RK2.F90 @@ -123,6 +123,9 @@ module MOM_dynamics_unsplit_RK2 !! the extent to which the treatment of gravity waves !! is forward-backward (0) or simulated backward !! Euler (1). 0 is almost always used. + logical :: use_correct_dt_visc !< If true, use the correct timestep in the calculation of the + !! turbulent mixed layer properties for viscosity. + !! The default should be true, but it is false. logical :: debug !< If true, write verbose checksums for debugging purposes. logical :: module_is_initialized = .false. !< Record whether this mouled has been initialzed. @@ -238,8 +241,8 @@ subroutine step_MOM_dyn_unsplit_RK2(u_in, v_in, h_in, tv, visc, Time_local, dt, real, dimension(SZIB_(G),SZJ_(G),SZK_(G)) :: up ! Predicted zonal velocities [L T-1 ~> m s-1] real, dimension(SZI_(G),SZJB_(G),SZK_(G)) :: vp ! Predicted meridional velocities [L T-1 ~> m s-1] real, dimension(:,:), pointer :: p_surf => NULL() - real :: dt_pred ! The time step for the predictor part of the baroclinic - ! time stepping [T ~> s]. + real :: dt_pred ! The time step for the predictor part of the baroclinic time stepping [T ~> s] + real :: dt_visc ! The time step for a part of the update due to viscosity [T ~> s] logical :: dyn_p_surf integer :: i, j, k, is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke @@ -280,17 +283,15 @@ subroutine step_MOM_dyn_unsplit_RK2(u_in, v_in, h_in, tv, visc, Time_local, dt, call cpu_clock_begin(id_clock_continuity) ! This is a duplicate calculation of the last continuity from the previous step ! and could/should be optimized out. -AJA - call continuity(u_in, v_in, h_in, hp, uh, vh, dt_pred, G, GV, US, & - CS%continuity_CSp, OBC=CS%OBC) + call continuity(u_in, v_in, h_in, hp, uh, vh, dt_pred, G, GV, US, CS%continuity_CSp, OBC=CS%OBC) call cpu_clock_end(id_clock_continuity) call pass_var(hp, G%Domain, clock=id_clock_pass) call pass_vector(uh, vh, G%Domain, clock=id_clock_pass) ! h_av = (h + hp)/2 (used in PV denominator) call cpu_clock_begin(id_clock_mom_update) - do k=1,nz - do j=js-2,je+2 ; do i=is-2,ie+2 - h_av(i,j,k) = (h_in(i,j,k) + hp(i,j,k)) * 0.5 + do k=1,nz ; do j=js-2,je+2 ; do i=is-2,ie+2 + h_av(i,j,k) = (h_in(i,j,k) + hp(i,j,k)) * 0.5 enddo ; enddo ; enddo call cpu_clock_end(id_clock_mom_update) @@ -305,8 +306,7 @@ subroutine step_MOM_dyn_unsplit_RK2(u_in, v_in, h_in, tv, visc, Time_local, dt, if (dyn_p_surf) then ; do j=js-2,je+2 ; do i=is-2,ie+2 p_surf(i,j) = 0.5*p_surf_begin(i,j) + 0.5*p_surf_end(i,j) enddo ; enddo ; endif - call PressureForce(h_in, tv, CS%PFu, CS%PFv, G, GV, US, & - CS%PressureForce_CSp, CS%ALE_CSp, p_surf) + call PressureForce(h_in, tv, CS%PFu, CS%PFv, G, GV, US, CS%PressureForce_CSp, CS%ALE_CSp, p_surf) call cpu_clock_end(id_clock_pres) call pass_vector(CS%PFu, CS%PFv, G%Domain, clock=id_clock_pass) call pass_vector(CS%CAu, CS%CAv, G%Domain, clock=id_clock_pass) @@ -339,12 +339,11 @@ subroutine step_MOM_dyn_unsplit_RK2(u_in, v_in, h_in, tv, visc, Time_local, dt, ! up[n-1/2] <- up*[n-1/2] + dt/2 d/dz visc d/dz up[n-1/2] call cpu_clock_begin(id_clock_vertvisc) call enable_averages(dt, Time_local, CS%diag) - call set_viscous_ML(up, vp, h_av, tv, forces, visc, dt, G, GV, US, & - CS%set_visc_CSp) + dt_visc = dt_pred ; if (CS%use_correct_dt_visc) dt_visc = dt + call set_viscous_ML(up, vp, h_av, tv, forces, visc, dt_visc, G, GV, US, CS%set_visc_CSp) call disable_averaging(CS%diag) - call vertvisc_coef(up, vp, h_av, forces, visc, dt_pred, G, GV, US, & - CS%vertvisc_CSp, CS%OBC) + call vertvisc_coef(up, vp, h_av, forces, visc, dt_pred, G, GV, US, CS%vertvisc_CSp, CS%OBC) call vertvisc(up, vp, h_av, forces, visc, dt_pred, CS%OBC, CS%ADp, CS%CDp, & G, GV, US, CS%vertvisc_CSp) call cpu_clock_end(id_clock_vertvisc) @@ -395,12 +394,10 @@ subroutine step_MOM_dyn_unsplit_RK2(u_in, v_in, h_in, tv, visc, Time_local, dt, ! up[n] <- up* + dt d/dz visc d/dz up ! u[n] <- u*[n] + dt d/dz visc d/dz u[n] call cpu_clock_begin(id_clock_vertvisc) - call vertvisc_coef(up, vp, h_av, forces, visc, dt, G, GV, US, & - CS%vertvisc_CSp, CS%OBC) + call vertvisc_coef(up, vp, h_av, forces, visc, dt, G, GV, US, CS%vertvisc_CSp, CS%OBC) call vertvisc(up, vp, h_av, forces, visc, dt, CS%OBC, CS%ADp, CS%CDp, & G, GV, US, CS%vertvisc_CSp, CS%taux_bot, CS%tauy_bot) - call vertvisc_coef(u_in, v_in, h_av, forces, visc, dt, G, GV, US, & - CS%vertvisc_CSp, CS%OBC) + call vertvisc_coef(u_in, v_in, h_av, forces, visc, dt, G, GV, US, CS%vertvisc_CSp, CS%OBC) call vertvisc(u_in, v_in, h_av, forces, visc, dt, CS%OBC, CS%ADp, CS%CDp,& G, GV, US, CS%vertvisc_CSp, CS%taux_bot, CS%tauy_bot) call cpu_clock_end(id_clock_vertvisc) @@ -594,6 +591,11 @@ subroutine initialize_dyn_unsplit_RK2(u, v, h, Time, G, GV, US, param_file, diag "If SPLIT is false and USE_RK2 is true, BEGW can be "//& "between 0 and 0.5 to damp gravity waves.", & units="nondim", default=0.0) + call get_param(param_file, mdl, "FIX_UNSPLIT_DT_VISC_BUG", CS%use_correct_dt_visc, & + "If true, use the correct timestep in the viscous terms applied in the first "//& + "predictor step with the unsplit time stepping scheme, and in the calculation "//& + "of the turbulent mixed layer properties for viscosity with unsplit or "//& + "unsplit_RK2. The default should be true.", default=.false.) call get_param(param_file, mdl, "DEBUG", CS%debug, & "If true, write out verbose debugging data.", & default=.false., debuggingParam=.true.) From b8c3570260e74940bf0af06e6502e61d5293ac0f Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sat, 9 May 2020 11:27:23 -0400 Subject: [PATCH 269/316] +Add false position iteration for MLD to ePBL Added the option to replace bisection with false position iteration when determining the mixed layer depth. The new option is selected with the new runtime parameter EPBL_MLD_BISECTION = False. When EPBL_MLD_TOLERANCE = 1 m, the new option reduces the average number of iterations from 9.53 to 4.23 in the OM4_05 test case. When EPBL_MLD_TOLERANCE = 0.001 m, the average is reduced from 19.4 iterations to 7.65 with the new option. By default all answers are bitwise identical, but there are changes to the entries in the MOM_parameter_doc files, both from the new option and from not reporting other ePBL options when they are not valid options. --- .../vertical/MOM_energetic_PBL.F90 | 99 ++++++++++++++----- 1 file changed, 77 insertions(+), 22 deletions(-) diff --git a/src/parameterizations/vertical/MOM_energetic_PBL.F90 b/src/parameterizations/vertical/MOM_energetic_PBL.F90 index a9e68736e7..2a66c60c88 100644 --- a/src/parameterizations/vertical/MOM_energetic_PBL.F90 +++ b/src/parameterizations/vertical/MOM_energetic_PBL.F90 @@ -4,6 +4,7 @@ module MOM_energetic_PBL ! 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, CLOCK_ROUTINE +use MOM_coms, only : EFP_type, real_to_EFP, EFP_to_real, operator(+), assignment(=), EFP_sum_across_PEs use MOM_diag_mediator, only : post_data, register_diag_field, safe_alloc_alloc use MOM_diag_mediator, only : time_type, diag_ctrl use MOM_domains, only : create_group_pass, do_group_pass, group_pass_type @@ -33,12 +34,12 @@ module MOM_energetic_PBL type, public :: energetic_PBL_CS ; private !/ Constants - real :: VonKar = 0.41 !< The von Karman coefficient. This should be runtime, but because - !! it is runtime in KPP and set to 0.4 it might change answers. - real :: omega !< The Earth's rotation rate [T-1 ~> s-1]. - real :: 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 - !! sqrt((1-of)*f^2 + of*4*omega^2) [nondim]. + real :: VonKar = 0.41 !< The von Karman coefficient. This should be a runtime parameter, + !! but because it is set to 0.4 at runtime in KPP it might change answers. + real :: omega !< The Earth's rotation rate [T-1 ~> s-1]. + real :: 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 + !! sqrt((1-omega_frac)*f^2 + omega_frac*4*omega^2) [nondim]. !/ Convection related terms real :: nstar !< The fraction of the TKE input to the mixed layer available to drive @@ -47,9 +48,14 @@ module MOM_energetic_PBL !! TKE produced by buoyancy. !/ Mixing Length terms - logical :: Use_MLD_iteration=.false. !< False to use old ePBL method. - logical :: MLD_iteration_guess=.false. !< False to default to guessing half the - !! ocean depth for the iteration. + logical :: Use_MLD_iteration !< If true, use the proximity to the bottom of the actively turbulent + !! surface boundary layer to constrain the mixing lengths. + logical :: MLD_iteration_guess !< False to default to guessing half the + !! ocean depth for the first iteration. + logical :: MLD_bisection !! If true, use bisection with the iterative determination of the + !! self-consistent mixed layer depth. Otherwise use the false position + !! after a maximum and minimum bound have been evaluated and the + !! returned value from the previous guess or bisection before this. integer :: max_MLD_its !< The maximum number of iterations that can be used to find a !! self-consistent mixed layer depth with Use_MLD_iteration. real :: MixLenExponent !< Exponent in the mixing length shape-function. @@ -179,6 +185,8 @@ module MOM_energetic_PBL LA, & !< Langmuir number [nondim] LA_MOD !< Modified Langmuir number [nondim] + type(EFP_type), dimension(2) :: sum_its !< The total number of iterations and columns worked on + real, allocatable, dimension(:,:,:) :: & Velocity_Scale, & !< The velocity scale used in getting Kd [Z T-1 ~> m s-1] Mixing_Length !< The length scale used in getting Kd [Z ~> m] @@ -215,6 +223,8 @@ module MOM_energetic_PBL character*(20), parameter :: ADDITIVE_STRING = "ADDITIVE" !>@} +logical :: report_avg_its = .false. ! Report the average number of ePBL iterations for debugging. + !> A type for conveniently passing around ePBL diagnostics for a column. type, public :: ePBL_column_diags ; private !>@{ Local column copies of energy change diagnostics, all in [R Z3 T-3 ~> W m-2]. @@ -755,6 +765,8 @@ subroutine ePBL_column(h, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, B_flux, abs ! manner giving a usable guess. When it does fail, it is due to convection ! within the boundary layer. Likely, a new method e.g. surface_disconnect, ! can improve this. + real :: dMLD_min ! The change in diagnosed mixed layer depth when the guess is min_MLD [Z ~> m] + real :: dMLD_max ! The change in diagnosed mixed layer depth when the guess is max_MLD [Z ~> m] logical :: FIRST_OBL ! Flag for computing "found" Mixing layer depth logical :: OBL_converged ! Flag for convergence of MLD integer :: OBL_it ! Iteration counter @@ -829,6 +841,8 @@ subroutine ePBL_column(h, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, B_flux, abs max_MLD = 0.0 ; do k=1,nz ; max_MLD = max_MLD + h(k)*GV%H_to_Z ; enddo !min_MLD will initialize as 0. min_MLD = 0.0 + ! Set values of the wrong signs to indicate that these changes are not based on valid estimates + ! dMLD_min = -1.0*US%m_to_Z ; dMLD_max = 1.0*US%m_to_Z ! If no first guess is provided for MLD, try the middle of the water column if (MLD_guess <= min_MLD) MLD_guess = 0.5 * (min_MLD + max_MLD) @@ -1408,17 +1422,37 @@ subroutine ePBL_column(h, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, B_flux, abs !New method uses ML_DEPTH as computed in ePBL routine MLD_found = MLD_output - if (MLD_found - CS%MLD_tol > MLD_guess) then - min_MLD = MLD_guess - elseif (abs(MLD_guess - MLD_found) < CS%MLD_tol) then + if (MLD_found - MLD_guess > CS%MLD_tol) then + min_MLD = MLD_guess ; dMLD_min = MLD_found - MLD_guess + elseif (abs(MLD_found - MLD_guess) < CS%MLD_tol) then OBL_converged = .true. ! Break convergence loop - else - max_MLD = MLD_guess ! We know this guess was too deep + else ! We know this guess was too deep + max_MLD = MLD_guess ; dMLD_max = MLD_found - MLD_guess ! < -CS%MLD_tol endif - ! For next pass, guess average of minimum and maximum values. - !### We should try using the false position method instead of simple bisection. - MLD_guess = 0.5*(min_MLD + max_MLD) + if (.not.OBL_converged) then ; if (CS%MLD_bisection) then + ! For the next pass, guess the average of the minimum and maximum values. + MLD_guess = 0.5*(min_MLD + max_MLD) + else ! Try using the false position method or the returned value instead of simple bisection. + ! Taking the occasional step with MLD_output empirically step helps to converge faster. + if ((dMLD_min > 0.0) .and. (dMLD_max < 0.0) .and. (OBL_it > 2) .and. (mod(OBL_it-1,4)>0)) then + ! Both bounds have valid change estimates and are probably in the range of possible outputs. + MLD_Guess = (dMLD_min*max_MLD - dMLD_max*min_MLD) / (dMLD_min - dMLD_max) + elseif ((MLD_found > min_MLD) .and. (MLD_found < max_MLD)) then + ! The output MLD_found is an interesting guess, as it likely to bracket the true solution + ! along with the previous value of MLD_guess and to be close to the solution. + MLD_guess = MLD_found + else ! Bisect if the other guesses would be out-of-bounds. This does not happen much. + MLD_guess = 0.5*(min_MLD + max_MLD) + endif + endif ; endif + endif + if ((OBL_converged) .or. (OBL_it==CS%Max_MLD_Its)) then + if (report_avg_its) then + CS%sum_its(1) = CS%sum_its(1) + real_to_EFP(real(OBL_it)) + CS%sum_its(2) = CS%sum_its(2) + real_to_EFP(1.0) + endif + exit endif enddo ! Iteration loop for converged boundary layer thickness. if (CS%Use_LT) then @@ -2131,16 +2165,22 @@ subroutine energetic_PBL_init(Time, G, GV, US, param_file, diag, CS) endif call get_param(param_file, mdl, "MLD_ITERATION_GUESS", CS%MLD_ITERATION_GUESS, & - "A logical that specifies whether or not to use the "//& - "previous timestep MLD as a first guess in the MLD iteration. "//& - "The default is false to facilitate reproducibility.", default=.false.) + "If true, use the previous timestep MLD as a first guess in the MLD iteration, "//& + "otherwise use half the ocean depth as the first guess of the boundary layer "//& + "depth. The default is false to facilitate reproducibility.", & + default=.false., do_not_log=.not.CS%Use_MLD_iteration) call get_param(param_file, mdl, "EPBL_MLD_TOLERANCE", CS%MLD_tol, & "The tolerance for the iteratively determined mixed "//& "layer depth. This is only used with USE_MLD_ITERATION.", & - units="meter", default=1.0, scale=US%m_to_Z) + units="meter", default=1.0, scale=US%m_to_Z, do_not_log=.not.CS%Use_MLD_iteration) + call get_param(param_file, mdl, "EPBL_MLD_BISECTION", CS%MLD_bisection, & + "If true, use bisection with the iterative determination of the self-consistent "//& + "mixed layer depth. Otherwise use the false position after a maximum and minimum "//& + "bound have been evaluated and the returned value or bisection before this.", & + default=.true., do_not_log=.not.CS%Use_MLD_iteration) !### The default should become false. call get_param(param_file, mdl, "EPBL_MLD_MAX_ITS", CS%max_MLD_its, & "The maximum number of iterations that can be used to find a self-consistent "//& - "mixed layer depth. For now, due to the use of bisection, the maximum number "//& + "mixed layer depth. If EPBL_MLD_BISECTION is true, the maximum number "//& "iteractions needed is set by Depth/2^MAX_ITS < EPBL_MLD_TOLERANCE.", & default=20, do_not_log=.not.CS%Use_MLD_iteration) if (.not.CS%Use_MLD_iteration) CS%Max_MLD_Its = 1 @@ -2339,6 +2379,10 @@ subroutine energetic_PBL_init(Time, G, GV, US, param_file, diag, CS) "If true, temperature and salinity are used as state "//& "variables.", default=.true.) + if (report_avg_its) then + CS%sum_its(1) = real_to_EFP(0.0) ; CS%sum_its(2) = real_to_EFP(0.0) + endif + if (max(CS%id_TKE_wind, CS%id_TKE_MKE, CS%id_TKE_conv, & CS%id_TKE_mixing, CS%id_TKE_mech_decay, CS%id_TKE_forcing, & CS%id_TKE_conv_decay) > 0) then @@ -2370,6 +2414,9 @@ subroutine energetic_PBL_end(CS) type(energetic_PBL_CS), pointer :: CS !< Energetic_PBL control structure that !! will be deallocated in this subroutine. + character(len=256) :: mesg + real :: avg_its + if (.not.associated(CS)) return if (allocated(CS%ML_depth)) deallocate(CS%ML_depth) @@ -2387,6 +2434,14 @@ subroutine energetic_PBL_end(CS) if (allocated(CS%Mixing_Length)) deallocate(CS%Mixing_Length) if (allocated(CS%Velocity_Scale)) deallocate(CS%Velocity_Scale) + if (report_avg_its) then + call EFP_sum_across_PEs(CS%sum_its, 2) + + avg_its = EFP_to_real(CS%sum_its(1)) / EFP_to_real(CS%sum_its(2)) + write (mesg,*) "Average ePBL iterations = ", avg_its + call MOM_mesg(mesg) + endif + deallocate(CS) end subroutine energetic_PBL_end From f90a4151d477f9145aa72ab19fff1430f410122b Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sun, 10 May 2020 07:05:05 -0400 Subject: [PATCH 270/316] Corrected dOxygenization of two comments --- src/parameterizations/vertical/MOM_energetic_PBL.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/parameterizations/vertical/MOM_energetic_PBL.F90 b/src/parameterizations/vertical/MOM_energetic_PBL.F90 index 2a66c60c88..e2fda25f6d 100644 --- a/src/parameterizations/vertical/MOM_energetic_PBL.F90 +++ b/src/parameterizations/vertical/MOM_energetic_PBL.F90 @@ -52,7 +52,7 @@ module MOM_energetic_PBL !! surface boundary layer to constrain the mixing lengths. logical :: MLD_iteration_guess !< False to default to guessing half the !! ocean depth for the first iteration. - logical :: MLD_bisection !! If true, use bisection with the iterative determination of the + logical :: MLD_bisection !< If true, use bisection with the iterative determination of the !! self-consistent mixed layer depth. Otherwise use the false position !! after a maximum and minimum bound have been evaluated and the !! returned value from the previous guess or bisection before this. @@ -223,7 +223,7 @@ module MOM_energetic_PBL character*(20), parameter :: ADDITIVE_STRING = "ADDITIVE" !>@} -logical :: report_avg_its = .false. ! Report the average number of ePBL iterations for debugging. +logical :: report_avg_its = .false. !< Report the average number of ePBL iterations for debugging. !> A type for conveniently passing around ePBL diagnostics for a column. type, public :: ePBL_column_diags ; private From 6ca31848ea77c8868fb179ef2f136a091f7540a6 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Mon, 11 May 2020 14:33:49 -0400 Subject: [PATCH 271/316] Replaced array syntax additions in MOM_ice_shelf Replaced array syntax arithmetic with explicit loops in shelf_calc_flux, so that uninitialized values in halo points could not trigger model failures. All answers are bitwise identical. --- src/ice_shelf/MOM_ice_shelf.F90 | 20 +++++++++++--------- 1 file changed, 11 insertions(+), 9 deletions(-) diff --git a/src/ice_shelf/MOM_ice_shelf.F90 b/src/ice_shelf/MOM_ice_shelf.F90 index 891d6b3ea7..8d012377a5 100644 --- a/src/ice_shelf/MOM_ice_shelf.F90 +++ b/src/ice_shelf/MOM_ice_shelf.F90 @@ -607,15 +607,16 @@ subroutine shelf_calc_flux(sfc_state, fluxes, Time, time_step, CS, forces) ISS%tflux_ocn(i,j) = 0.0 endif -! haline_driving(:,:) = sfc_state%sss(i,j) - Sbdry(i,j) +! haline_driving(i,j) = sfc_state%sss(i,j) - Sbdry(i,j) enddo ! i-loop enddo ! j-loop - ! ISS%water_flux = net liquid water into the ocean [R Z T-1 ~> kg m-2 s-1] - fluxes%iceshelf_melt(:,:) = ISS%water_flux(:,:) * CS%flux_factor do j=js,je ; do i=is,ie + ! ISS%water_flux = net liquid water into the ocean [R Z T-1 ~> kg m-2 s-1] + fluxes%iceshelf_melt(i,j) = ISS%water_flux(i,j) * CS%flux_factor + if ((sfc_state%ocean_mass(i,j) > CS%col_mass_melt_threshold) .and. & (ISS%area_shelf_h(i,j) > 0.0) .and. (CS%isthermo)) then @@ -653,11 +654,10 @@ subroutine shelf_calc_flux(sfc_state, fluxes, Time, time_step, CS, forces) ISS%water_flux(i,j) = 0.0 fluxes%iceshelf_melt(i,j) = 0.0 endif ! area_shelf_h - enddo ; enddo ! i- and j-loops - ! mass flux [R Z L2 T-1 ~> kg s-1], part of ISOMIP diags. - mass_flux(:,:) = 0.0 - mass_flux(:,:) = ISS%water_flux(:,:) * ISS%area_shelf_h(:,:) + ! mass flux [R Z L2 T-1 ~> kg s-1], part of ISOMIP diags. + mass_flux(i,j) = ISS%water_flux(i,j) * ISS%area_shelf_h(i,j) + enddo ; enddo ! i- and j-loops if (CS%active_shelf_dynamics .or. CS%override_shelf_movement) then call cpu_clock_begin(id_clock_pass) @@ -690,7 +690,7 @@ subroutine shelf_calc_flux(sfc_state, fluxes, Time, time_step, CS, forces) ! 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, US, US%s_to_T*time_step, Time, & - sfc_state%ocean_mass(:,:), coupled_GL) + sfc_state%ocean_mass, coupled_GL) endif @@ -1735,7 +1735,9 @@ subroutine update_shelf_mass(G, US, CS, ISS, Time) call time_interp_external(CS%id_read_mass, Time, ISS%mass_shelf) ! This should only be done if time_interp_external did an update. - ISS%mass_shelf(:,:) = US%kg_m3_to_R*US%m_to_Z * ISS%mass_shelf(:,:) ! Rescale after time_interp + do j=js,je ; do i=is,ie + ISS%mass_shelf(i,j) = US%kg_m3_to_R*US%m_to_Z * ISS%mass_shelf(i,j) ! Rescale after time_interp + enddo ; enddo do j=js,je ; do i=is,ie ISS%area_shelf_h(i,j) = 0.0 From 9f7587a57fe3ac3b045a433bdf04fdeedc8b2aaa Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Mon, 11 May 2020 14:38:13 -0400 Subject: [PATCH 272/316] Replaced array syntax in MOM_internal_tides Replaced array syntax sums in MOM_internal_tides with explicit loops. Also documented internal variable units in MOM_internal_tides, and noted an incorrect expression in PPM_angular_advect with a comment (with '###') and a suggested correction. All answers are bitwise identical because the bug was noted but not corrected. --- .../lateral/MOM_internal_tides.F90 | 225 +++++++++--------- 1 file changed, 115 insertions(+), 110 deletions(-) diff --git a/src/parameterizations/lateral/MOM_internal_tides.F90 b/src/parameterizations/lateral/MOM_internal_tides.F90 index dda892dc3e..6145fb1dce 100644 --- a/src/parameterizations/lateral/MOM_internal_tides.F90 +++ b/src/parameterizations/lateral/MOM_internal_tides.F90 @@ -558,7 +558,7 @@ subroutine propagate_int_tide(h, tv, cn, TKE_itidal_input, vel_btTide, Nb, dt, & ! Output 2-D energy loss (summed over angles) for each freq and mode do m=1,CS%NMode ; do fr=1,CS%Nfreq if (CS%id_itidal_loss_mode(fr,m) > 0 .or. CS%id_allprocesses_loss_mode(fr,m) > 0) then - itidal_loss_mode(:,:) = 0.0 ! wave-drag processes (could do others as well) + itidal_loss_mode(:,:) = 0.0 ! wave-drag processes (could do others as well) allprocesses_loss_mode(:,:) = 0.0 ! all processes summed together do a=1,CS%nAngle ; do j=js,je ; do i=is,ie itidal_loss_mode(i,j) = itidal_loss_mode(i,j) + CS%TKE_itidal_loss(i,j,a,fr,m) @@ -886,12 +886,16 @@ subroutine PPM_angular_advect(En2d, CFL_ang, Flux_En, NAngle, dt, halo_ang) !! across angles [R Z3 T-2 ~> J m-2]. ! Local variables real :: flux - real :: u_ang - real :: Angle_size - real :: I_Angle_size - real :: I_dt + real :: u_ang ! Angular propagation speed [Rad T-1 ~> Rad s-1] + real :: Angle_size ! The size of each orientation wedge in radians [Rad] + real :: I_Angle_size ! The inverse of the the orientation wedges [Rad-1] + real :: I_dt ! The inverse of the timestep [T-1 ~> s-1] + real :: aR, aL ! Left and right edge estimates of energy density [R Z3 T-2 rad-1 ~> J m-2 rad-1] + real :: dMx, dMn + real :: Ep, Ec, Em ! Mean angular energy density for three successive wedges in angular + ! orientation [R Z3 T-2 rad-1 ~> J m-2 rad-1] + real :: dA, mA, a6 ! Difference, mean, and curvature of energy density [R Z3 T-2 rad-1 ~> J m-2 rad-1] integer :: a - real :: aR, aL, dMx, dMn, Ep, Ec, Em, dA, mA, a6 I_dt = 1 / dt Angle_size = (8.0*atan(1.0)) / (real(NAngle)) @@ -902,9 +906,12 @@ subroutine PPM_angular_advect(En2d, CFL_ang, Flux_En, NAngle, dt, halo_ang) u_ang = CFL_ang(A)*Angle_size*I_dt if (u_ang >= 0.0) then ! Implementation of PPM-H3 - Ep = En2d(a+1)*I_Angle_size !MEAN ANGULAR ENERGY DENSITY FOR WEDGE (Jm-2/rad) - Ec = En2d(a) *I_Angle_size !MEAN ANGULAR ENERGY DENSITY FOR WEDGE (Jm-2/rad) - Em = En2d(a-1)*I_Angle_size !MEAN ANGULAR ENERGY DENSITY FOR WEDGE (Jm-2/rad) + ! Convert wedge-integrated energy density into angular energy densities for three successive + ! wedges around the source wedge for this flux [R Z3 T-2 rad-1 ~> J m-2 rad-1]. + Ep = En2d(a+1)*I_Angle_size + Ec = En2d(a) *I_Angle_size + Em = En2d(a-1)*I_Angle_size + ! Calculate and bound edge values of energy density. aL = ( 5.*Ec + ( 2.*Em - Ep ) )/6. ! H3 estimate aL = max( min(Ec,Em), aL) ; aL = min( max(Ec,Em), aL) ! Bound aR = ( 5.*Ec + ( 2.*Ep - Em ) )/6. ! H3 estimate @@ -918,17 +925,21 @@ subroutine PPM_angular_advect(En2d, CFL_ang, Flux_En, NAngle, dt, halo_ang) aR = 3.*Ec - 2.*aL !? endif a6 = 6.*Ec - 3. * (aR + aL) ! Curvature - ! CALCULATE FLUX RATE (Jm-2/s) + ! Calculate angular flux rate [R Z3 T-3 ~> W m-2] flux = u_ang*( aR + 0.5 * CFL_ang(A) * ( ( aL - aR ) + a6 * ( 1. - 2./3. * CFL_ang(A) ) ) ) - !flux = u_ang*( aR - 0.5 * CFL_ang(A) * ( ( aR - aL ) - a6 * ( 1. - 2./3. * CFL_ang(A) ) ) ) - ! CALCULATE AMOUNT FLUXED (Jm-2) + ! The following expression copied from tracer_advect is equivalent. + ! flux = u_ang*( aR - 0.5 * CFL_ang(A) * ( ( aR - aL ) - a6 * ( 1. - 2./3. * CFL_ang(A) ) ) ) + ! Calculate amount of energy fluxed between wedges [R Z3 T-2 ~> J m-2] Flux_En(A) = dt * flux !Flux_En(A) = (dt * I_Angle_size) * flux else ! Implementation of PPM-H3 - Ep = En2d(a+2)*I_Angle_size !MEAN ANGULAR ENERGY DENSITY FOR WEDGE (Jm-2/rad) - Ec = En2d(a+1)*I_Angle_size !MEAN ANGULAR ENERGY DENSITY FOR WEDGE (Jm-2/rad) - Em = En2d(a) *I_Angle_size !MEAN ANGULAR ENERGY DENSITY FOR WEDGE (Jm-2/rad) + ! Convert wedge-integrated energy density into angular energy densities for three successive + ! wedges around the source wedge for this flux [R Z3 T-2 rad-1 ~> J m-2 rad-1]. + Ep = En2d(a+2)*I_Angle_size + Ec = En2d(a+1)*I_Angle_size + Em = En2d(a) *I_Angle_size + ! Calculate and bound edge values of energy density. aL = ( 5.*Ec + ( 2.*Em - Ep ) )/6. ! H3 estimate aL = max( min(Ec,Em), aL) ; aL = min( max(Ec,Em), aL) ! Bound aR = ( 5.*Ec + ( 2.*Ep - Em ) )/6. ! H3 estimate @@ -942,10 +953,12 @@ subroutine PPM_angular_advect(En2d, CFL_ang, Flux_En, NAngle, dt, halo_ang) aR = 3.*Ec - 2.*aL endif a6 = 6.*Ec - 3. * (aR + aL) ! Curvature - ! CALCULATE FLUX RATE (Jm-2/s) + ! Calculate angular flux rate [R Z3 T-3 ~> W m-2] + !### This expression is wrong, because it was just copied from above. The correct one is below flux = u_ang*( aR + 0.5 * CFL_ang(A) * ( ( aL - aR ) + a6 * ( 1. - 2./3. * CFL_ang(A) ) ) ) - !flux = u_ang*( aL + 0.5 * CFL_ang(A) * ( ( aR - aL ) + a6 * ( 1. - 2./3. * CFL_ang(A) ) ) ) - ! CALCULATE AMOUNT FLUXED (Jm-2) + ! This is the correct expression; note that CFL_ang is negative here, so it looks a bit odd. + !flux = u_ang*( aL - 0.5 * CFL_ang(A) * ( ( aR - aL ) + a6 * ( 1. + 2./3. * CFL_ang(A) ) ) ) + ! Calculate amount of energy fluxed between wedges [R Z3 T-2 ~> J m-2] Flux_En(A) = dt * flux !Flux_En(A) = (dt * I_Angle_size) * flux endif @@ -1014,7 +1027,7 @@ subroutine propagate(En, cn, freq, dt, G, US, CS, NAngle) ! 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.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)) * & @@ -1058,21 +1071,21 @@ subroutine propagate(En, cn, freq, dt, G, US, CS, NAngle) ! Apply propagation in x-direction (reflection included) LB%jsh = jsh ; LB%jeh = jeh ; LB%ish = ish ; LB%ieh = ieh - call propagate_x(En(:,:,:), speed_x, Cgx_av(:), dCgx(:), dt, G, US, CS%nAngle, CS, LB) + call propagate_x(En, speed_x, Cgx_av, dCgx, dt, G, US, CS%nAngle, CS, LB) ! Check for energy conservation on computational domain (for debugging) - !call sum_En(G,CS,En(:,:,:),'post-propagate_x') + !call sum_En(G, CS, En, 'post-propagate_x') ! Update halos - call pass_var(En(:,:,:),G%domain) + call pass_var(En, G%domain) ! Apply propagation in y-direction (reflection included) ! LB%jsh = js ; LB%jeh = je ; LB%ish = is ; LB%ieh = ie ! Use if no teleport LB%jsh = jsh ; LB%jeh = jeh ; LB%ish = ish ; LB%ieh = ieh - call propagate_y(En(:,:,:), speed_y, Cgy_av(:), dCgy(:), dt, G, US, CS%nAngle, CS, LB) + call propagate_y(En, speed_y, Cgy_av, dCgy, dt, G, US, CS%nAngle, CS, LB) ! Check for energy conservation on computational domain (for debugging) - !call sum_En(G,CS,En(:,:,:),'post-propagate_y') + !call sum_En(G, CS, En, 'post-propagate_y') endif end subroutine propagate @@ -1084,7 +1097,7 @@ subroutine propagate_corner_spread(En, energized_wedge, NAngle, speed, dt, G, CS type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. real, dimension(G%isd:G%ied,G%jsd:G%jed), & intent(inout) :: En !< The energy density integrated over an angular - !! band [R Z3 T-2 ~> J m-2], intent in/out. + !! band [R Z3 T-2 ~> J m-2]. real, dimension(G%IsdB:G%IedB,G%Jsd:G%Jed), & intent(in) :: speed !< The magnitude of the group velocity at the cell !! corner points [L T-1 ~> m s-1]. @@ -1351,7 +1364,7 @@ subroutine propagate_x(En, speed_x, Cgx_av, dCgx, dt, G, US, Nangle, CS, LB) !! discretized wave energy spectrum. real, dimension(G%isd:G%ied,G%jsd:G%jed,Nangle), & intent(inout) :: En !< The energy density integrated over an angular - !! band [R Z3 T-2 ~> J m-2], intent in/out. + !! band [R Z3 T-2 ~> J m-2]. real, dimension(G%IsdB:G%IedB,G%jsd:G%jed), & intent(in) :: speed_x !< The magnitude of the group velocity at the !! Cu points [L T-1 ~> m s-1]. @@ -1404,18 +1417,18 @@ subroutine propagate_x(En, speed_x, Cgx_av, dCgx, dt, G, US, Nangle, CS, LB) enddo ! a-loop ! Only reflect newly arrived energy; existing energy in incident wedge is not reflected - ! and will eventually propagate out of cell. (Thid code only reflects if En > 0) - call reflect(Fdt_m(:,:,:), Nangle, CS, G, LB) - call teleport(Fdt_m(:,:,:), Nangle, CS, G, LB) - call reflect(Fdt_p(:,:,:), Nangle, CS, G, LB) - call teleport(Fdt_p(:,:,:), Nangle, CS, G, LB) + ! and will eventually propagate out of cell. (This code only reflects if En > 0.) + call reflect(Fdt_m, Nangle, CS, G, LB) + call teleport(Fdt_m, Nangle, CS, G, LB) + call reflect(Fdt_p, Nangle, CS, G, LB) + call teleport(Fdt_p, Nangle, CS, G, LB) - ! Update reflected energy (Jm-2) - do j=jsh,jeh ; do i=ish,ieh + ! Update reflected energy [R Z3 T-2 ~> J m-2] + do a=1,Nangle ; do j=jsh,jeh ; do i=ish,ieh ! if ((En(i,j,a) + G%IareaT(i,j)*(Fdt_m(i,j,a) + Fdt_p(i,j,a))) < 0.0) & ! for debugging ! call MOM_error(FATAL, "propagate_x: OutFlux>Available") - En(i,j,:) = En(i,j,:) + G%IareaT(i,j)*(Fdt_m(i,j,:) + Fdt_p(i,j,:)) - enddo ; enddo + En(i,j,a) = En(i,j,a) + G%IareaT(i,j)*(Fdt_m(i,j,a) + Fdt_p(i,j,a)) + enddo ; enddo ; enddo end subroutine propagate_x @@ -1426,7 +1439,7 @@ subroutine propagate_y(En, speed_y, Cgy_av, dCgy, dt, G, US, Nangle, CS, LB) !! discretized wave energy spectrum. real, dimension(G%isd:G%ied,G%jsd:G%jed,Nangle), & intent(inout) :: En !< The energy density integrated over an angular - !! band [R Z3 T-2 ~> J m-2], intent in/out. + !! band [R Z3 T-2 ~> J m-2]. real, dimension(G%isd:G%ied,G%JsdB:G%JedB), & intent(in) :: speed_y !< The magnitude of the group velocity at the !! Cv points [L T-1 ~> m s-1]. @@ -1486,13 +1499,13 @@ subroutine propagate_y(En, speed_y, Cgy_av, dCgy, dt, G, US, Nangle, CS, LB) enddo ! a-loop ! Only reflect newly arrived energy; existing energy in incident wedge is not reflected - ! and will eventually propagate out of cell. (Thid code only reflects if En > 0) - call reflect(Fdt_m(:,:,:), Nangle, CS, G, LB) - call teleport(Fdt_m(:,:,:), Nangle, CS, G, LB) - call reflect(Fdt_p(:,:,:), Nangle, CS, G, LB) - call teleport(Fdt_p(:,:,:), Nangle, CS, G, LB) + ! and will eventually propagate out of cell. (This code only reflects if En > 0.) + call reflect(Fdt_m, Nangle, CS, G, LB) + call teleport(Fdt_m, Nangle, CS, G, LB) + call reflect(Fdt_p, Nangle, CS, G, LB) + call teleport(Fdt_p, Nangle, CS, G, LB) - ! Update reflected energy (Jm-2) + ! Update reflected energy [R Z3 T-2 ~> J m-2] do a=1,Nangle ; do j=jsh,jeh ; do i=ish,ieh ! if ((En(i,j,a) + G%IareaT(i,j)*(Fdt_m(i,j,a) + Fdt_p(i,j,a))) < 0.0) & ! for debugging ! call MOM_error(FATAL, "propagate_y: OutFlux>Available", .true.) @@ -1521,8 +1534,7 @@ subroutine zonal_flux_En(u, h, hL, hR, uh, dt, G, US, j, ish, ieh, vol_CFL) !! the cell areas when estimating the CFL number. ! Local variables real :: CFL ! The CFL number based on the local velocity and grid spacing [nondim]. - real :: curv_3 ! A measure of the thickness curvature over a grid length, - ! with the same units as h_in. + real :: curv_3 ! A measure of the energy density curvature over a grid length [R Z3 T-2 ~> J m-2] integer :: i do I=ish-1,ieh @@ -1566,8 +1578,7 @@ subroutine merid_flux_En(v, h, hL, hR, vh, dt, G, US, J, ish, ieh, vol_CFL) !! the CFL number. ! Local variables real :: CFL ! The CFL number based on the local velocity and grid spacing [nondim]. - real :: curv_3 ! A measure of the thickness curvature over a grid length, - ! with the same units as h_in. + real :: curv_3 ! A measure of the energy density curvature over a grid length [R Z3 T-2 ~> J m-2] integer :: i do i=ish,ieh @@ -1603,18 +1614,18 @@ subroutine reflect(En, NAngle, CS, G, LB) type(loop_bounds_type), intent(in) :: LB !< A structure with the active energy loop bounds. ! Local variables real, dimension(G%isd:G%ied,G%jsd:G%jed) :: angle_c - ! angle of boudary wrt equator + ! angle of boundary wrt equator [rad] real, dimension(G%isd:G%ied,G%jsd:G%jed) :: part_refl ! fraction of wave energy reflected - ! values should collocate with angle_c + ! values should collocate with angle_c [nondim] logical, dimension(G%isd:G%ied,G%jsd:G%jed) :: ridge ! tags of cells with double reflection - real :: TwoPi ! 2*pi - real :: Angle_size ! size of beam wedge (rad) - real :: angle_wall ! angle of coast/ridge/shelf wrt equator - real, dimension(1:NAngle) :: angle_i ! angle of incident ray wrt equator - real :: angle_r ! angle of reflected ray wrt equator + real :: TwoPi ! 2*pi = 6.2831853... [nondim] + real :: Angle_size ! size of beam wedge [rad] + real :: angle_wall ! angle of coast/ridge/shelf wrt equator [rad] + real, dimension(1:NAngle) :: angle_i ! angle of incident ray wrt equator [rad] + real :: angle_r ! angle of reflected ray wrt equator [rad] real, dimension(1:Nangle) :: En_reflected integer :: i, j, a, a_r, na !integer :: isd, ied, jsd, jed ! start and end local indices on data domain @@ -1623,7 +1634,6 @@ subroutine reflect(En, NAngle, CS, G, LB) ! (values exclude halos) integer :: ish, ieh, jsh, jeh ! start and end local indices on data domain ! leaving out outdated halo points (march in) - integer :: id_g, jd_g ! global (decomp-invar) indices !isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed isc = G%isc ; iec = G%iec ; jsc = G%jsc ; jec = G%jec @@ -1643,59 +1653,54 @@ subroutine reflect(En, NAngle, CS, G, LB) ridge = CS%refl_dbl En_reflected(:) = 0.0 - !do j=jsc-1,jec+1 - do j=jsh,jeh - !do i=isc-1,iec+1 - do i=ish,ieh - ! jd_g = j + G%jdg_offset ; 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) /= CS%nullangle) then - do a=1,NAngle - if (En(i,j,a) > 0.0) then - ! if ray is incident, keep specified boundary angle - if (sin(angle_i(a) - angle_c(i,j)) >= 0.0) then - angle_wall = angle_c(i,j) - ! if ray is not incident but in ridge cell, use complementary angle - elseif (ridge(i,j)) then - angle_wall = angle_c(i,j) + 0.5*TwoPi - if (angle_wall > TwoPi) then - angle_wall = angle_wall - TwoPi*floor(abs(angle_wall)/TwoPi) - elseif (angle_wall < 0.0) then - angle_wall = angle_wall + TwoPi*ceiling(abs(angle_wall)/TwoPi) - endif - ! if ray is not incident and not in a ridge cell, keep specified angle - else - angle_wall = angle_c(i,j) - endif - ! do reflection - if (sin(angle_i(a) - angle_wall) >= 0.0) then - angle_r = 2.0*angle_wall - angle_i(a) - if (angle_r > TwoPi) then - angle_r = angle_r - TwoPi*floor(abs(angle_r)/TwoPi) - elseif (angle_r < 0.0) then - angle_r = angle_r + TwoPi*ceiling(abs(angle_r)/TwoPi) - endif - a_r = nint(angle_r/Angle_size) + 1 - do while (a_r > Nangle) ; a_r = a_r - Nangle ; enddo - 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 - endif + do j=jsh,jeh ; do i=ish,ieh + ! redistribute energy in angular space if ray will hit boundary + ! i.e., if energy is in a reflecting cell + if (angle_c(i,j) /= CS%nullangle) then + do a=1,NAngle ; if (En(i,j,a) > 0.0) then + if (sin(angle_i(a) - angle_c(i,j)) >= 0.0) then + ! if ray is incident, keep specified boundary angle + angle_wall = angle_c(i,j) + elseif (ridge(i,j)) then + ! if ray is not incident but in ridge cell, use complementary angle + angle_wall = angle_c(i,j) + 0.5*TwoPi + if (angle_wall > TwoPi) then + angle_wall = angle_wall - TwoPi*floor(abs(angle_wall)/TwoPi) + elseif (angle_wall < 0.0) then + angle_wall = angle_wall + TwoPi*ceiling(abs(angle_wall)/TwoPi) endif - enddo ! a-loop - En(i,j,:) = En(i,j,:) + En_reflected(:) - En_reflected(:) = 0.0 - endif - enddo ! i-loop - enddo ! j-loop + else + ! if ray is not incident and not in a ridge cell, keep specified angle + angle_wall = angle_c(i,j) + endif + + ! do reflection + if (sin(angle_i(a) - angle_wall) >= 0.0) then + angle_r = 2.0*angle_wall - angle_i(a) + if (angle_r > TwoPi) then + angle_r = angle_r - TwoPi*floor(abs(angle_r)/TwoPi) + elseif (angle_r < 0.0) then + angle_r = angle_r + TwoPi*ceiling(abs(angle_r)/TwoPi) + endif + a_r = nint(angle_r/Angle_size) + 1 + do while (a_r > Nangle) ; a_r = a_r - Nangle ; enddo + 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 + endif + endif ; enddo ! a-loop + do a=1,NAngle + En(i,j,a) = En(i,j,a) + En_reflected(a) + En_reflected(a) = 0.0 + enddo ! a-loop + endif + enddo ; enddo ! i- and j-loops ! Check to make sure no energy gets onto land (only run for debugging) ! do a=1,NAngle ; do j=jsc,jec ; do i=isc,iec ! if (En(i,j,a) > 0.001 .and. G%mask2dT(i,j) == 0) then - ! jd_g = j + G%jdg_offset ; id_g = i + G%idg_offset - ! write (mesg,*) 'En=', En(i,j,a), 'a=', a, 'ig_g=',id_g, 'jg_g=',jd_g + ! write (mesg,*) 'En=', En(i,j,a), 'a=', a, 'ig_g=',i+G%idg_offset, 'jg_g=',j+G%jdg_offset ! call MOM_error(FATAL, "reflect: Energy detected out of bounds: "//trim(mesg), .true.) ! endif ! enddo ; enddo ; enddo @@ -1717,17 +1722,17 @@ subroutine teleport(En, NAngle, CS, G, LB) type(loop_bounds_type), intent(in) :: LB !< A structure with the active energy loop bounds. ! Local variables real, dimension(G%isd:G%ied,G%jsd:G%jed) :: angle_c - ! angle of boudary wrt equator + ! angle of boundary wrt equator [rad] real, dimension(G%isd:G%ied,G%jsd:G%jed) :: part_refl ! fraction of wave energy reflected - ! values should collocate with angle_c + ! values should collocate with angle_c [nondim] logical, dimension(G%isd:G%ied,G%jsd:G%jed) :: pref_cell ! flag for partial reflection logical, dimension(G%isd:G%ied,G%jsd:G%jed) :: ridge - ! tags of cells with double reflection - real :: TwoPi ! size of beam wedge (rad) - real :: Angle_size ! size of beam wedge (rad) - real, dimension(1:NAngle) :: angle_i ! angle of incident ray wrt equator + ! tags of cells with double reflection + real :: TwoPi ! 2*pi = 6.2831853... [nondim] + real :: Angle_size ! size of beam wedge [rad] + real, dimension(1:NAngle) :: angle_i ! angle of incident ray wrt equator [rad] real, dimension(1:NAngle) :: cos_angle, sin_angle real :: En_tele ! energy to be "teleported" [R Z3 T-2 ~> J m-2] character(len=160) :: mesg ! The text of an error message @@ -2295,8 +2300,8 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) CS%TKE_itidal_loss(:,:,:,:,:) = 0.0 allocate(CS%TKE_Froude_loss(isd:ied,jsd:jed,num_angle,num_freq,num_mode)) CS%TKE_Froude_loss(:,:,:,:,:) = 0.0 - allocate(CS%tot_leak_loss(isd:ied,jsd:jed)) ; CS%tot_leak_loss(:,:) = 0.0 - allocate(CS%tot_quad_loss(isd:ied,jsd:jed) ) ; CS%tot_quad_loss(:,:) = 0.0 + allocate(CS%tot_leak_loss(isd:ied,jsd:jed)) ; CS%tot_leak_loss(:,:) = 0.0 + allocate(CS%tot_quad_loss(isd:ied,jsd:jed) ) ; CS%tot_quad_loss(:,:) = 0.0 allocate(CS%tot_itidal_loss(isd:ied,jsd:jed)) ; CS%tot_itidal_loss(:,:) = 0.0 allocate(CS%tot_Froude_loss(isd:ied,jsd:jed)) ; CS%tot_Froude_loss(:,:) = 0.0 From 34196a2eb4cbd684cd02ec9e3b0a18e1e423eef1 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Mon, 11 May 2020 14:47:21 -0400 Subject: [PATCH 273/316] Added array-syntax notation for full-array copies Added array-syntax notation for full-array copies in offline_diabatic_ale. All answers are bitwise identical. --- src/tracer/MOM_offline_main.F90 | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/src/tracer/MOM_offline_main.F90 b/src/tracer/MOM_offline_main.F90 index 65f83ecfea..a0f7b23346 100644 --- a/src/tracer/MOM_offline_main.F90 +++ b/src/tracer/MOM_offline_main.F90 @@ -722,9 +722,9 @@ subroutine offline_diabatic_ale(fluxes, Time_start, Time_end, CS, h_pre, eatr, e ! Add diurnal cycle for shortwave radiation (only used if run in ocean-only mode) if (CS%diurnal_SW .and. CS%read_sw) then - sw(:,:) = fluxes%sw - sw_vis(:,:) = fluxes%sw_vis_dir - sw_nir(:,:) = fluxes%sw_nir_dir + sw(:,:) = fluxes%sw(:,:) + sw_vis(:,:) = fluxes%sw_vis_dir(:,:) + sw_nir(:,:) = fluxes%sw_nir_dir(:,:) call offline_add_diurnal_SW(fluxes, CS%G, Time_start, Time_end) endif @@ -738,9 +738,9 @@ subroutine offline_diabatic_ale(fluxes, Time_start, Time_end, CS, h_pre, eatr, e CS%G, CS%GV, CS%US, CS%tv, CS%optics, CS%tracer_flow_CSp, CS%debug) if (CS%diurnal_SW .and. CS%read_sw) then - fluxes%sw(:,:) = sw - fluxes%sw_vis_dir(:,:) = sw_vis - fluxes%sw_nir_dir(:,:) = sw_nir + fluxes%sw(:,:) = sw(:,:) + fluxes%sw_vis_dir(:,:) = sw_vis(:,:) + fluxes%sw_nir_dir(:,:) = sw_nir(:,:) endif if (CS%debug) then From e68a66489d692ac21a746a9684dd716edcf84e31 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Mon, 11 May 2020 14:50:14 -0400 Subject: [PATCH 274/316] Removed duplicate dimension declarations Removed duplicated dimension declarations for two ppoly variables in bulk_average in MOM_lateral_boundary_diffusion. When I first saw these declarations, they were confusing to me, as I was unsure at first whether they are actually declaring 4-d arrays or 2-d arrays (it is the latter). Also removed unneeded full array syntax in 2 subroutine calls, and merged a pair of do-loop statements with common loop contents. All answers are bitwise identical. --- src/tracer/MOM_lateral_boundary_diffusion.F90 | 38 +++++++++---------- 1 file changed, 18 insertions(+), 20 deletions(-) diff --git a/src/tracer/MOM_lateral_boundary_diffusion.F90 b/src/tracer/MOM_lateral_boundary_diffusion.F90 index 8b9be533d5..f244931376 100644 --- a/src/tracer/MOM_lateral_boundary_diffusion.F90 +++ b/src/tracer/MOM_lateral_boundary_diffusion.F90 @@ -171,16 +171,14 @@ subroutine lateral_boundary_diffusion(G, GV, US, h, Coef_x, Coef_y, dt, Reg, CS) ! for diagnostics if (tracer%id_lbdxy_conc > 0 .or. tracer%id_lbdxy_cont > 0 .or. tracer%id_lbdxy_cont_2d > 0) then - tendency(:,:,:) = 0.0 + tendency(:,:,:) = 0.0 endif - do j = G%jsc-1, G%jec+1 - ! Interpolate state to interface - do i = G%isc-1, G%iec+1 - call build_reconstructions_1d( CS%remap_CS, G%ke, h(i,j,:), tracer%t(i,j,:), ppoly0_coefs(i,j,:,:), & - ppoly0_E(i,j,:,:), ppoly_S, remap_method, GV%H_subroundoff, GV%H_subroundoff) - enddo - enddo + ! Interpolate state to interface + do j=G%jsc-1,G%jec+1 ; do i=G%isc-1,G%iec+1 + call build_reconstructions_1d( CS%remap_CS, G%ke, h(i,j,:), tracer%t(i,j,:), ppoly0_coefs(i,j,:,:), & + ppoly0_E(i,j,:,:), ppoly_S, remap_method, GV%H_subroundoff, GV%H_subroundoff) + enddo ; enddo ! Diffusive fluxes in the i-direction uFlx(:,:,:) = 0. vFlx(:,:,:) = 0. @@ -253,41 +251,41 @@ subroutine lateral_boundary_diffusion(G, GV, US, h, Coef_x, Coef_y, dt, Reg, CS) if (tracer%id_lbd_dfy>0) call post_data(tracer%id_lbd_dfy, vFlx*Idt, CS%diag) if (tracer%id_lbd_dfx_2d>0) then uwork_2d(:,:) = 0. - do k=1,GV%ke; do j=G%jsc,G%jec; do I=G%isc-1,G%iec + do k=1,GV%ke ; do j=G%jsc,G%jec ; do I=G%isc-1,G%iec uwork_2d(I,j) = uwork_2d(I,j) + (uFlx(I,j,k) * Idt) - enddo; enddo; enddo + enddo ; enddo ; enddo call post_data(tracer%id_lbd_dfx_2d, uwork_2d, CS%diag) endif if (tracer%id_lbd_dfy_2d>0) then vwork_2d(:,:) = 0. - do k=1,GV%ke; do J=G%jsc-1,G%jec; do i=G%isc,G%iec + do k=1,GV%ke ; do J=G%jsc-1,G%jec ; do i=G%isc,G%iec vwork_2d(i,J) = vwork_2d(i,J) + (vFlx(i,J,k) * Idt) - enddo; enddo; enddo + enddo ; enddo ; enddo call post_data(tracer%id_lbd_dfy_2d, vwork_2d, CS%diag) endif ! post tendency of tracer content if (tracer%id_lbdxy_cont > 0) then - call post_data(tracer%id_lbdxy_cont, tendency(:,:,:), CS%diag) + call post_data(tracer%id_lbdxy_cont, tendency, CS%diag) endif ! post depth summed tendency for tracer content if (tracer%id_lbdxy_cont_2d > 0) then tendency_2d(:,:) = 0. - do j = G%jsc,G%jec ; do i = G%isc,G%iec - do k = 1, GV%ke + do j=G%jsc,G%jec ; do i=G%isc,G%iec + do k=1,GV%ke tendency_2d(i,j) = tendency_2d(i,j) + tendency(i,j,k) enddo enddo ; enddo - call post_data(tracer%id_lbdxy_cont_2d, tendency_2d(:,:), CS%diag) + call post_data(tracer%id_lbdxy_cont_2d, tendency_2d, CS%diag) endif ! post tendency of tracer concentration; this step must be ! done after posting tracer content tendency, since we alter ! the tendency array and its units. if (tracer%id_lbdxy_conc > 0) then - do k = 1, GV%ke ; do j = G%jsc,G%jec ; do i = G%isc,G%iec + 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 call post_data(tracer%id_lbdxy_conc, tendency, CS%diag) @@ -306,9 +304,9 @@ real function bulk_average(boundary, nk, deg, h, hBLT, phi, ppoly0_E, ppoly0_coe real, dimension(nk) :: h !< Layer thicknesses [H ~> m or kg m-2] real :: hBLT !< Depth of the boundary layer [H ~> m or kg m-2] real, dimension(nk) :: phi !< Scalar quantity - real, dimension(nk,2) :: ppoly0_E(:,:) !< Edge value of polynomial - real, dimension(nk,deg+1) :: ppoly0_coefs(:,:) !< Coefficients of polynomial - integer :: method !< Remapping scheme to use + real, dimension(nk,2) :: ppoly0_E !< Edge value of polynomial + real, dimension(nk,deg+1) :: ppoly0_coefs !< Coefficients of polynomial + integer :: method !< Remapping scheme to use integer :: k_top !< Index of the first layer within the boundary real :: zeta_top !< Fraction of the layer encompassed by the bottom boundary layer From 21c33b10a5742a274e8a6399c7cc22488c8874f6 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Mon, 11 May 2020 14:54:53 -0400 Subject: [PATCH 275/316] Merge scaling factors when reading Nikurashin input Combined scaling factors when reading internal tide TKE input from a file for use with the Nikurashin mixing scheme, while also eliminating an array-syntax multiplication. All answers are bitwise identical. --- src/parameterizations/vertical/MOM_tidal_mixing.F90 | 7 +++---- 1 file changed, 3 insertions(+), 4 deletions(-) diff --git a/src/parameterizations/vertical/MOM_tidal_mixing.F90 b/src/parameterizations/vertical/MOM_tidal_mixing.F90 index 27b316e144..e7d5bcc476 100644 --- a/src/parameterizations/vertical/MOM_tidal_mixing.F90 +++ b/src/parameterizations/vertical/MOM_tidal_mixing.F90 @@ -509,8 +509,7 @@ logical function tidal_mixing_init(Time, G, GV, US, param_file, diag, CS) filename) call safe_alloc_ptr(CS%TKE_Niku,is,ie,js,je) ; CS%TKE_Niku(:,:) = 0.0 call MOM_read_data(filename, 'TKE_input', CS%TKE_Niku, G%domain, timelevel=1, & ! ??? timelevel -aja - scale=US%W_m2_to_RZ3_T3) - CS%TKE_Niku(:,:) = Niku_scale * CS%TKE_Niku(:,:) + scale=Niku_scale*US%W_m2_to_RZ3_T3) call get_param(param_file, mdl, "GAMMA_NIKURASHIN",CS%Gamma_lee, & "The fraction of the lee wave energy that is dissipated "//& @@ -781,7 +780,7 @@ subroutine calculate_CVMix_tidal(h, j, G, GV, US, CS, N2_int, Kd_lay, Kv) ! XXX: Temporary de-scaling of N2_int(i,:) into a temporary variable - do k = 1,G%ke+1 + do k=1,G%ke+1 N2_int_i(k) = US%s_to_T**2 * N2_int(i,k) enddo @@ -876,7 +875,7 @@ subroutine calculate_CVMix_tidal(h, j, G, GV, US, CS, N2_int, Kd_lay, Kv) CVmix_tidal_params_user = CS%CVMix_tidal_params) ! XXX: Temporary de-scaling of N2_int(i,:) into a temporary variable - do k = 1,G%ke+1 + do k=1,G%ke+1 N2_int_i(k) = US%s_to_T**2 * N2_int(i,k) enddo From a6445be6f40fb7b2ba657428ab37949a08497491 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Mon, 11 May 2020 15:51:00 -0400 Subject: [PATCH 276/316] +Fixed pointer indexing in update_ALE_sponge_field Added grid type arguments to calls to update_ALE_sponge_field so that the internal array pointers set by this routine will use the same indexing conventions as the rest of the MOM6 code. Also added comments describing some arguments and other variables and got rid of some unneeded line continuations in MOM.F90. All answers are bitwise identical, but there are two new arguments to update_ALE_sponge_field. --- src/core/MOM.F90 | 19 ++-- .../vertical/MOM_ALE_sponge.F90 | 106 +++++++++--------- 2 files changed, 61 insertions(+), 64 deletions(-) diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index aff4860a21..25ed1b1f6e 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -1013,7 +1013,7 @@ subroutine step_MOM_dynamics(forces, p_surf_begin, p_surf_end, dt, dt_thermo, & Time_local + real_to_time(US%T_to_s*(bbl_time_int-dt)), 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, US, & + call set_viscous_BBL(CS%u, CS%v, CS%h, CS%tv, CS%visc, G, GV, US, & CS%set_visc_CSp, symmetrize=.true.) call cpu_clock_end(id_clock_BBL_visc) if (showCallTree) call callTree_wayPoint("done with set_viscous_BBL (step_MOM)") @@ -2204,7 +2204,7 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & allocate(CS%tv%frazil(isd:ied,jsd:jed)) ; CS%tv%frazil(:,:) = 0.0 endif if (bound_salinity) then - allocate(CS%tv%salt_deficit(isd:ied,jsd:jed)) ; CS%tv%salt_deficit(:,:)=0.0 + allocate(CS%tv%salt_deficit(isd:ied,jsd:jed)) ; CS%tv%salt_deficit(:,:) = 0.0 endif if (bulkmixedlayer .or. use_temperature) then @@ -2369,20 +2369,17 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & if (associated(sponge_in_CSp)) then ! TODO: Implementation and testing of non-ALE spong rotation - call MOM_error(FATAL, "Index rotation of non-ALE sponge is not yet " & - // "implemented.") + call MOM_error(FATAL, "Index rotation of non-ALE sponge is not yet implemented.") endif if (associated(ALE_sponge_in_CSp)) then - call rotate_ALE_sponge(ALE_sponge_in_CSp, G_in, CS%ALE_sponge_CSp, G, & - turns, param_file) - call update_ALE_sponge_field(CS%ALE_sponge_CSp, T_in, CS%T) - call update_ALE_sponge_field(CS%ALE_sponge_CSp, S_in, CS%S) + call rotate_ALE_sponge(ALE_sponge_in_CSp, G_in, CS%ALE_sponge_CSp, G, turns, param_file) + call update_ALE_sponge_field(CS%ALE_sponge_CSp, T_in, G, GV, CS%T) + call update_ALE_sponge_field(CS%ALE_sponge_CSp, S_in, G, GV, CS%S) endif if (associated(OBC_in)) & - call rotate_OBC_init(OBC_in, G, GV, US, param_file, CS%tv, restart_CSp, & - CS%OBC) + call rotate_OBC_init(OBC_in, G, GV, US, param_file, CS%tv, restart_CSp, CS%OBC) deallocate(u_in) deallocate(v_in) @@ -2427,7 +2424,7 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & G => CS%G if (CS%debug .or. CS%G%symmetric) then call clone_MOM_domain(CS%G%Domain, CS%G%Domain_aux, symmetric=.false.) - else ; CS%G%Domain_aux => CS%G%Domain ;endif + else ; CS%G%Domain_aux => CS%G%Domain ; endif G%ke = GV%ke endif diff --git a/src/parameterizations/vertical/MOM_ALE_sponge.F90 b/src/parameterizations/vertical/MOM_ALE_sponge.F90 index b791535ed1..fe1ccab53d 100644 --- a/src/parameterizations/vertical/MOM_ALE_sponge.F90 +++ b/src/parameterizations/vertical/MOM_ALE_sponge.F90 @@ -171,7 +171,7 @@ subroutine initialize_ALE_sponge_fixed(Iresttime, G, param_file, CS, data_h, nz_ integer :: i, j, k, col, total_sponge_cols, total_sponge_cols_u, total_sponge_cols_v character(len=10) :: remapScheme if (associated(CS)) then - call MOM_error(WARNING, "initialize_sponge called with an associated "// & + call MOM_error(WARNING, "initialize_ALE_sponge_fixed called with an associated "// & "control structure.") return endif @@ -260,14 +260,14 @@ 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 + 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)) & @@ -276,9 +276,9 @@ subroutine initialize_ALE_sponge_fixed(Iresttime, G, param_file, CS, data_h, nz_ 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 @@ -286,7 +286,7 @@ subroutine initialize_ALE_sponge_fixed(Iresttime, G, param_file, CS, data_h, nz_ 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 + col = col + 1 endif enddo ; enddo @@ -323,7 +323,7 @@ subroutine initialize_ALE_sponge_fixed(Iresttime, G, param_file, CS, data_h, nz_ 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 + col = col + 1 endif enddo ; enddo @@ -415,7 +415,7 @@ subroutine initialize_ALE_sponge_varying(Iresttime, G, param_file, CS) character(len=10) :: remapScheme if (associated(CS)) then - call MOM_error(WARNING, "initialize_sponge called with an associated "// & + call MOM_error(WARNING, "initialize_ALE_sponge_varying called with an associated "// & "control structure.") return endif @@ -486,8 +486,8 @@ subroutine initialize_ALE_sponge_varying(Iresttime, G, param_file, CS) call log_param(param_file, mdl, "!Total sponge columns at h points", total_sponge_cols, & "The total number of columns where sponges are applied at h points.") if (CS%sponge_uv) then - 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(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 @@ -578,7 +578,7 @@ subroutine set_up_ALE_sponge_field_fixed(sp_val, G, f_ptr, CS) if (CS%fldno > MAX_FIELDS_) then write(mesg,'("Increase MAX_FIELDS_ to at least ",I3," in MOM_memory.h or decrease & &the number of fields to be damped in the call to & - &initialize_sponge." )') CS%fldno + &initialize_ALE_sponge." )') CS%fldno call MOM_error(FATAL,"set_up_ALE_sponge_field: "//mesg) endif @@ -605,8 +605,8 @@ subroutine set_up_ALE_sponge_field_varying(filename, fieldname, Time, G, GV, US, type(time_type), intent(in) :: Time !< The current model time type(ocean_grid_type), intent(in) :: G !< Grid structure (in). type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & target, intent(in) :: f_ptr !< Pointer to the field to be damped (in). type(ALE_sponge_CS), pointer :: CS !< Sponge control structure (in/out). @@ -634,7 +634,7 @@ subroutine set_up_ALE_sponge_field_varying(filename, fieldname, Time, G, GV, US, if (CS%fldno > MAX_FIELDS_) then write(mesg,'("Increase MAX_FIELDS_ to at least ",I3," in MOM_memory.h or decrease & &the number of fields to be damped in the call to & - &initialize_sponge." )') CS%fldno + &initialize_ALE_sponge." )') CS%fldno call MOM_error(FATAL,"set_up_ALE_sponge_field: "//mesg) endif ! get a unique time interp id for this field. If sponge data is ongrid, then setup @@ -788,11 +788,11 @@ subroutine apply_ALE_sponge(h, dt, G, GV, US, CS, Time) type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure (in). type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(inout) :: h !< Layer thickness [H ~> m or kg m-2] (in) real, intent(in) :: dt !< The amount of time covered by this call [T ~> s]. 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). + !! that is set by a previous call to initialize_ALE_sponge (in). type(time_type), optional, intent(in) :: Time !< The current model date real :: damp ! The timestep times the local damping coefficient [nondim]. @@ -833,8 +833,8 @@ subroutine apply_ALE_sponge(h, dt, G, GV, US, CS, Time) nz_data = CS%Ref_val(m)%nz_data allocate(sp_val(G%isd:G%ied,G%jsd:G%jed,1:nz_data)) allocate(mask_z(G%isd:G%ied,G%jsd:G%jed,1:nz_data)) - sp_val(:,:,:)=0.0 - mask_z(:,:,:)=0.0 + sp_val(:,:,:) = 0.0 + mask_z(:,:,:) = 0.0 call horiz_interp_and_extrap_tracer(CS%Ref_val(m)%id, Time, 1.0, G, sp_val, mask_z, z_in, & z_edges_in, missing_value, .true., .false., .false., & spongeOnGrid=CS%SpongeDataOngrid, m_to_Z=US%m_to_Z, & @@ -1003,17 +1003,20 @@ end subroutine apply_ALE_sponge !> Rotate the ALE sponge fields from the input to the model index map. subroutine rotate_ALE_sponge(sponge_in, G_in, sponge, G, turns, param_file) - type(ALE_sponge_CS), intent(in) :: sponge_in - type(ocean_grid_type), intent(in) :: G_in - type(ALE_sponge_CS), pointer :: sponge - type(ocean_grid_type), intent(in) :: G - integer, intent(in) :: turns - type(param_file_type), intent(in) :: param_file + type(ALE_sponge_CS), intent(in) :: sponge_in !< The control structure for this module with the + !! original grid rotation + type(ocean_grid_type), intent(in) :: G_in !< The ocean's grid structure with the original rotation. + type(ALE_sponge_CS), pointer :: sponge !< A pointer to the control that will be set up with + !! the new grid rotation + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure with the new rotation. + integer, intent(in) :: turns !< The number of 90-degree turns between grids + type(param_file_type), intent(in) :: param_file !< A structure indicating the open file + !! to parse for model parameter values. ! First part: Index construction ! 1. Reconstruct Iresttime(:,:) from sponge_in ! 2. rotate Iresttime(:,:) - ! 3. Call initialize_sponge using new grid and rotated Iresttime(:,:) + ! 3. Call initialize_ALE_sponge using new grid and rotated Iresttime(:,:) ! All the index adjustment should follow from the Iresttime rotation real, dimension(:,:), allocatable :: Iresttime_in, Iresttime @@ -1040,15 +1043,13 @@ subroutine rotate_ALE_sponge(sponge_in, G_in, sponge, G, turns, param_file) endif ! Re-populate the 2D Iresttime and data_h arrays on the original grid - do c = 1, sponge_in%num_col + do c=1,sponge_in%num_col c_i = sponge_in%col_i(c) c_j = sponge_in%col_j(c) Iresttime_in(c_i, c_j) = sponge_in%Iresttime_col(c) - if (fixed_sponge) then - do k = 1, nz_data - data_h(c_i, c_j, k) = sponge_in%Ref_h%p(k,c) - enddo - endif + if (fixed_sponge) then ; do k=1,nz_data + data_h(c_i, c_j, k) = sponge_in%Ref_h%p(k,c) + enddo ; endif enddo call rotate_array(Iresttime_in, turns, Iresttime) @@ -1076,19 +1077,13 @@ subroutine rotate_ALE_sponge(sponge_in, G_in, sponge, G, turns, param_file) allocate(sp_val(G%isd:G%ied, G%jsd:G%jed, nz_data)) endif - do n = 1, sponge_in%fldno + do n=1,sponge_in%fldno ! Assume that tracers are pointers and are remapped in other functions(?) sp_ptr => sponge_in%var(n)%p sp_val_in(:,:,:) = 0.0 - do c = 1, sponge_in%num_col - c_i = sponge_in%col_i(c) - c_j = sponge_in%col_j(c) - if (fixed_sponge) then - do k = 1, nz_data - sp_val_in(c_i, c_j, k) = sponge_in%Ref_val(n)%p(k,c) - enddo - endif - enddo + if (fixed_sponge) then ; do c=1,sponge_in%num_col ; do k=1,nz_data + sp_val_in(sponge_in%col_i(c), sponge_in%col_j(c), k) = sponge_in%Ref_val(n)%p(k,c) + enddo ; enddo ; endif call rotate_array(sp_val_in, turns, sp_val) if (fixed_sponge) then @@ -1144,17 +1139,22 @@ end subroutine rotate_ALE_sponge ! TODO: This function solely exists to replace field pointers in the sponge ! after rotation. This function is part of a temporary solution until ! something more robust is developed. -subroutine update_ALE_sponge_field(sponge, p_old, p_new) - type(ALE_sponge_CS), pointer :: sponge - real, dimension(:,:,:), target, intent(in) :: p_old - real, dimension(:,:,:), target, intent(in) :: p_new +subroutine update_ALE_sponge_field(sponge, p_old, G, GV, p_new) + type(ALE_sponge_CS), pointer :: sponge !< A pointer to the control structure for this module + !! that is set by a previous call to initialize_ALE_sponge. + real, dimension(:,:,:), & + target, intent(in) :: p_old !< The previous array of target values + type(ocean_grid_type), intent(in) :: G !< The updated ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + target, intent(in) :: p_new !< The new array of target values integer :: n - do n = 1, sponge%fldno - if (associated(sponge%var(n)%p, p_old)) & - sponge%var(n)%p => p_new + do n=1,sponge%fldno + if (associated(sponge%var(n)%p, p_old)) sponge%var(n)%p => p_new enddo + end subroutine update_ALE_sponge_field @@ -1163,7 +1163,7 @@ end subroutine update_ALE_sponge_field !> This subroutine deallocates any memory associated with the ALE_sponge module. subroutine ALE_sponge_end(CS) type(ALE_sponge_CS), pointer :: CS !< A pointer to the control structure that is - !! set by a previous call to initialize_sponge. + !! set by a previous call to initialize_ALE_sponge. integer :: m From b2453e4fa78b7769cad724d10edab94837ebe8aa Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Mon, 11 May 2020 15:55:30 -0400 Subject: [PATCH 277/316] Added array-syntax notation for a full-array copy Added array-syntax notation for a full-array copy in ISOMIP_Tracer.F90. All answers are bitwise identical. --- src/tracer/ISOMIP_tracer.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/tracer/ISOMIP_tracer.F90 b/src/tracer/ISOMIP_tracer.F90 index c9bf98f7ff..5503287c50 100644 --- a/src/tracer/ISOMIP_tracer.F90 +++ b/src/tracer/ISOMIP_tracer.F90 @@ -287,7 +287,7 @@ subroutine ISOMIP_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, G if (.not.associated(CS)) return - melt(:,:) = fluxes%iceshelf_melt + melt(:,:) = fluxes%iceshelf_melt(:,:) ! max. melt mmax = MAXVAL(melt(is:ie,js:je)) From aeac463d7bb086edf28a4c50e5a73c113be184d5 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Mon, 11 May 2020 17:52:16 -0400 Subject: [PATCH 278/316] Initialized dMLD_min and dMLD_max in ePBL_column Initialized dMLD_min and dMLD_max in ePBL_column, and corrected a comment in response to helpful reviews from Brandon Reichl and Andrew Shao. Because these two arrays are not used until after the 3rd iteration, this may not matter to the solution, although it should help make the code clearer and avoids unused variables. All answers in the MOM6-examples test cases are bitwise identical. --- src/parameterizations/vertical/MOM_energetic_PBL.F90 | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/parameterizations/vertical/MOM_energetic_PBL.F90 b/src/parameterizations/vertical/MOM_energetic_PBL.F90 index e2fda25f6d..25e1f80ff0 100644 --- a/src/parameterizations/vertical/MOM_energetic_PBL.F90 +++ b/src/parameterizations/vertical/MOM_energetic_PBL.F90 @@ -839,10 +839,10 @@ subroutine ePBL_column(h, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, B_flux, abs !/The following lines are for the iteration over MLD ! max_MLD will initialized as ocean bottom depth max_MLD = 0.0 ; do k=1,nz ; max_MLD = max_MLD + h(k)*GV%H_to_Z ; enddo - !min_MLD will initialize as 0. + ! min_MLD will be initialized to 0. min_MLD = 0.0 ! Set values of the wrong signs to indicate that these changes are not based on valid estimates - ! dMLD_min = -1.0*US%m_to_Z ; dMLD_max = 1.0*US%m_to_Z + dMLD_min = -1.0*US%m_to_Z ; dMLD_max = 1.0*US%m_to_Z ! If no first guess is provided for MLD, try the middle of the water column if (MLD_guess <= min_MLD) MLD_guess = 0.5 * (min_MLD + max_MLD) @@ -1434,7 +1434,7 @@ subroutine ePBL_column(h, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, B_flux, abs ! For the next pass, guess the average of the minimum and maximum values. MLD_guess = 0.5*(min_MLD + max_MLD) else ! Try using the false position method or the returned value instead of simple bisection. - ! Taking the occasional step with MLD_output empirically step helps to converge faster. + ! Taking the occasional step with MLD_output empirically helps to converge faster. if ((dMLD_min > 0.0) .and. (dMLD_max < 0.0) .and. (OBL_it > 2) .and. (mod(OBL_it-1,4)>0)) then ! Both bounds have valid change estimates and are probably in the range of possible outputs. MLD_Guess = (dMLD_min*max_MLD - dMLD_max*min_MLD) / (dMLD_min - dMLD_max) From bbdef39ae9e48c74f3f82a1d6ed4f8ac358b37dc Mon Sep 17 00:00:00 2001 From: Jessica Meixner Date: Wed, 13 May 2020 14:23:35 -0400 Subject: [PATCH 279/316] Updates for wave coupling in NUOPC (#23) * Adding extra ensemble slot for waves. * Updates for wave coupling - Adding wave information to mech_forcing type to pass from ice_ocean_boundary to wave types - This is only set-up to read surface Stokes drift and guess the wavelength as something reasonable for now to demonstrate that it works. This needs to be set-up properly before merging this into the main repository. * Updates to make Stokes drift from multiple bands work with the coupler approach * Adding wave stokes drift import to nuopc cap Co-authored-by: Brandon Reichl --- .../MOM_surface_forcing_gfdl.F90 | 27 ++- config_src/coupled_driver/ocean_model_MOM.F90 | 2 +- config_src/nuopc_driver/mom_cap.F90 | 25 +++ config_src/nuopc_driver/mom_cap_methods.F90 | 52 +++++ .../nuopc_driver/mom_ocean_model_nuopc.F90 | 9 +- .../mom_surface_forcing_nuopc.F90 | 32 ++- src/core/MOM_forcing_type.F90 | 25 ++- src/user/MOM_wave_interface.F90 | 188 ++++++++++++------ 8 files changed, 289 insertions(+), 71 deletions(-) diff --git a/config_src/coupled_driver/MOM_surface_forcing_gfdl.F90 b/config_src/coupled_driver/MOM_surface_forcing_gfdl.F90 index 9743c7fa3f..187f8ab7b2 100644 --- a/config_src/coupled_driver/MOM_surface_forcing_gfdl.F90 +++ b/config_src/coupled_driver/MOM_surface_forcing_gfdl.F90 @@ -189,6 +189,12 @@ module MOM_surface_forcing_gfdl !! ice-shelves, expressed as a coefficient !! for divergence damping, as determined !! outside of the ocean model [m3 s-1] + real, pointer, dimension(:,:) :: ustk0 => NULL() !< + real, pointer, dimension(:,:) :: vstk0 => NULL() !< + real, pointer, dimension(:) :: stk_wavenumbers => NULL() !< + real, pointer, dimension(:,:,:) :: ustkb => NULL() !< + real, pointer, dimension(:,:,:) :: vstkb => NULL() !< + 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. @@ -196,6 +202,7 @@ module MOM_surface_forcing_gfdl !! 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. + integer :: num_stk_bands !< Number of Stokes drift bands passed through the coupler end type ice_ocean_boundary_type integer :: id_clock_forcing !< A CPU time clock @@ -275,7 +282,7 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, ! 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.) + 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) @@ -669,7 +676,7 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS, dt_ real :: mass_eff ! effective mass of sea ice for rigidity [kg m-2] real :: wt1, wt2 ! Relative weights of previous and current values of ustar, ND. - integer :: i, j, is, ie, js, je, Isq, Ieq, Jsq, Jeq, i0, j0 + integer :: i, j, is, ie, js, je, Isq, Ieq, Jsq, Jeq, i0, j0, istk integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB, isr, ier, jsr, jer integer :: isc_bnd, iec_bnd, jsc_bnd, jec_bnd @@ -710,6 +717,9 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS, dt_ (associated(IOB%mass_berg) .and. (.not. associated(forces%mass_berg))) ) & call allocate_mech_forcing(G, forces, iceberg=.true.) + if ( associated(IOB%ustk0) ) & + call allocate_mech_forcing(G, forces, waves=.true., num_stk_bands=IOB%num_stk_bands) + if (associated(IOB%ice_rigidity)) then rigidity_at_h(:,:) = 0.0 call safe_alloc_ptr(forces%rigidity_ice_u,IsdB,IedB,jsd,jed) @@ -769,6 +779,19 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS, dt_ forces%ustar(i,j) = wt1*forces%ustar(i,j) + wt2*ustar_tmp(i,j) enddo ; enddo endif + forces%stk_wavenumbers(:) = IOB%stk_wavenumbers + do j=js,je; do i=is,ie + forces%ustk0(i,j) = IOB%ustk0(i-I0,j-J0) ! How to be careful here that the domains are right? + forces%vstk0(i,j) = IOB%vstk0(i-I0,j-J0) + enddo ; enddo + call pass_vector(forces%ustk0,forces%vstk0, G%domain ) + do istk = 1,IOB%num_stk_bands + do j=js,je; do i=is,ie + forces%ustkb(i,j,istk) = IOB%ustkb(i-I0,j-J0,istk) + forces%vstkb(i,j,istk) = IOB%vstkb(i-I0,j-J0,istk) + enddo; enddo + call pass_vector(forces%ustkb(:,:,istk),forces%vstkb(:,:,istk), G%domain ) + enddo ! Find the net mass source in the input forcing without other adjustments. if (CS%approx_net_mass_src .and. associated(forces%net_mass_src)) then diff --git a/config_src/coupled_driver/ocean_model_MOM.F90 b/config_src/coupled_driver/ocean_model_MOM.F90 index 1f01845ae4..75b604a9d8 100644 --- a/config_src/coupled_driver/ocean_model_MOM.F90 +++ b/config_src/coupled_driver/ocean_model_MOM.F90 @@ -557,7 +557,7 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, time_start_upda ! For now, the waves are only updated on the thermodynamics steps, because that is where ! the wave intensities are actually used to drive mixing. At some point, the wave updates ! might also need to become a part of the ocean dynamics, according to B. Reichl. - call Update_Surface_Waves(OS%grid, OS%GV, OS%US, OS%time, ocean_coupling_time_step, OS%waves) + call Update_Surface_Waves(OS%grid, OS%GV, OS%US, OS%time, ocean_coupling_time_step, OS%waves, OS%forces) endif if ((OS%nstep==0) .and. (OS%nstep_thermo==0)) then ! This is the first call to update_ocean_model. diff --git a/config_src/nuopc_driver/mom_cap.F90 b/config_src/nuopc_driver/mom_cap.F90 index 12b12cf717..a8056129ff 100644 --- a/config_src/nuopc_driver/mom_cap.F90 +++ b/config_src/nuopc_driver/mom_cap.F90 @@ -606,6 +606,20 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) Ice_ocean_boundary%lrunoff = 0.0 Ice_ocean_boundary%frunoff = 0.0 + if (ocean_state%use_waves) then + Ice_ocean_boundary%num_stk_bands=ocean_state%Waves%NumBands + allocate ( Ice_ocean_boundary% ustk0 (isc:iec,jsc:jec), & + Ice_ocean_boundary% vstk0 (isc:iec,jsc:jec), & + Ice_ocean_boundary% ustkb (isc:iec,jsc:jec,Ice_ocean_boundary%num_stk_bands), & + Ice_ocean_boundary% vstkb (isc:iec,jsc:jec,Ice_ocean_boundary%num_stk_bands), & + Ice_ocean_boundary%stk_wavenumbers (Ice_ocean_boundary%num_stk_bands)) + Ice_ocean_boundary%ustk0 = 0.0 + Ice_ocean_boundary%vstk0 = 0.0 + Ice_ocean_boundary%stk_wavenumbers = ocean_state%Waves%WaveNum_Cen + Ice_ocean_boundary%ustkb = 0.0 + Ice_ocean_boundary%vstkb = 0.0 + endif + ocean_internalstate%ptr%ocean_state_type_ptr => ocean_state call ESMF_GridCompSetInternalState(gcomp, ocean_internalstate, rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return @@ -649,6 +663,17 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) !These are not currently used and changing requires a nuopc dictionary change !call fld_list_add(fldsToOcn_num, fldsToOcn, "mean_runoff_heat_flx" , "will provide") !call fld_list_add(fldsToOcn_num, fldsToOcn, "mean_calving_heat_flx" , "will provide") + if (ocean_state%use_waves) then + if (Ice_ocean_boundary%num_stk_bands > 3) then + call MOM_error(FATAL, "Number of Stokes Bands > 3, NUOPC cap not set up for this") + endif + call fld_list_add(fldsToOcn_num, fldsToOcn, "eastward_partitioned_stokes_drift_1" , "will provide") + call fld_list_add(fldsToOcn_num, fldsToOcn, "northward_partitioned_stokes_drift_1", "will provide") + call fld_list_add(fldsToOcn_num, fldsToOcn, "eastward_partitioned_stokes_drift_2" , "will provide") + call fld_list_add(fldsToOcn_num, fldsToOcn, "northward_partitioned_stokes_drift_2", "will provide") + call fld_list_add(fldsToOcn_num, fldsToOcn, "eastward_partitioned_stokes_drift_3" , "will provide") + call fld_list_add(fldsToOcn_num, fldsToOcn, "northward_partitioned_stokes_drift_3", "will provide") + endif !--------- export fields ------------- call fld_list_add(fldsFrOcn_num, fldsFrOcn, "ocean_mask" , "will provide") diff --git a/config_src/nuopc_driver/mom_cap_methods.F90 b/config_src/nuopc_driver/mom_cap_methods.F90 index f1be8a3ea3..8aca45094f 100644 --- a/config_src/nuopc_driver/mom_cap_methods.F90 +++ b/config_src/nuopc_driver/mom_cap_methods.F90 @@ -73,6 +73,8 @@ subroutine mom_import(ocean_public, ocean_grid, importState, ice_ocean_boundary, character(len=128) :: fldname real(ESMF_KIND_R8), allocatable :: taux(:,:) real(ESMF_KIND_R8), allocatable :: tauy(:,:) + real(ESMF_KIND_R8), allocatable :: stkx1(:,:),stkx2(:,:),stkx3(:,:) + real(ESMF_KIND_R8), allocatable :: stky1(:,:),stky2(:,:),stky3(:,:) character(len=*) , parameter :: subname = '(mom_import)' rc = ESMF_SUCCESS @@ -245,6 +247,56 @@ subroutine mom_import(ocean_public, ocean_grid, importState, ice_ocean_boundary, isc, iec, jsc, jec, ice_ocean_boundary%mi, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return + + !---- + ! Partitioned Stokes Drift Components + !---- + if ( associated(ice_ocean_boundary%ustkb) ) then + allocate(stkx1(isc:iec,jsc:jec)) + allocate(stky1(isc:iec,jsc:jec)) + allocate(stkx2(isc:iec,jsc:jec)) + allocate(stky2(isc:iec,jsc:jec)) + allocate(stkx3(isc:iec,jsc:jec)) + allocate(stky3(isc:iec,jsc:jec)) + + call state_getimport(importState,'eastward_partitioned_stokes_drift_1' , isc, iec, jsc, jec, stkx1,rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call state_getimport(importState,'northward_partitioned_stokes_drift_1', isc, iec, jsc, jec, stky1,rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call state_getimport(importState,'eastward_partitioned_stokes_drift_2' , isc, iec, jsc, jec, stkx2,rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call state_getimport(importState,'northward_partitioned_stokes_drift_2', isc, iec, jsc, jec, stky2,rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call state_getimport(importState,'eastward_partitioned_stokes_drift_3' , isc, iec, jsc, jec, stkx3,rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call state_getimport(importState,'northward_partitioned_stokes_drift_3', isc, iec, jsc, jec, stky3,rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + ! rotate from true zonal/meridional to local coordinates + do j = jsc, jec + jg = j + ocean_grid%jsc - jsc + do i = isc, iec + ig = i + ocean_grid%isc - isc + ice_ocean_boundary%ustkb(i,j,1) = ocean_grid%cos_rot(ig,jg)*stkx1(i,j) & + - ocean_grid%sin_rot(ig,jg)*stky1(i,j) + ice_ocean_boundary%vstkb(i,j,1) = ocean_grid%cos_rot(ig,jg)*stky1(i,j) & + + ocean_grid%sin_rot(ig,jg)*stkx1(i,j) + + ice_ocean_boundary%ustkb(i,j,2) = ocean_grid%cos_rot(ig,jg)*stkx2(i,j) & + - ocean_grid%sin_rot(ig,jg)*stky2(i,j) + ice_ocean_boundary%vstkb(i,j,2) = ocean_grid%cos_rot(ig,jg)*stky2(i,j) & + + ocean_grid%sin_rot(ig,jg)*stkx2(i,j) + + ice_ocean_boundary%ustkb(i,j,3) = ocean_grid%cos_rot(ig,jg)*stkx3(i,j) & + - ocean_grid%sin_rot(ig,jg)*stky3(i,j) + ice_ocean_boundary%vstkb(i,j,3) = ocean_grid%cos_rot(ig,jg)*stky3(i,j) & + + ocean_grid%sin_rot(ig,jg)*stkx3(i,j) + enddo + enddo + + deallocate(stkx1,stkx2,stkx3,stky1,stky2,stky3) + endif + end subroutine mom_import !> Maps outgoing ocean data to ESMF State diff --git a/config_src/nuopc_driver/mom_ocean_model_nuopc.F90 b/config_src/nuopc_driver/mom_ocean_model_nuopc.F90 index 0245d9633d..6a50d3c03c 100644 --- a/config_src/nuopc_driver/mom_ocean_model_nuopc.F90 +++ b/config_src/nuopc_driver/mom_ocean_model_nuopc.F90 @@ -143,7 +143,7 @@ module MOM_ocean_model_nuopc 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. + logical,public :: use_waves !< If true use wave coupling. logical :: icebergs_alter_ocean !< If true, the icebergs can change ocean the !! ocean dynamics and forcing fluxes. @@ -203,7 +203,7 @@ module MOM_ocean_model_nuopc type(marine_ice_CS), pointer :: & marine_ice_CSp => NULL() !< A pointer to the control structure for the !! marine ice effects module. - type(wave_parameters_cs), pointer :: & + type(wave_parameters_cs), pointer, public :: & 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 @@ -386,6 +386,9 @@ subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, gas_fields_ocn, i "If true, enables surface wave modules.", default=.false.) if (OS%use_waves) then call MOM_wave_interface_init(OS%Time, OS%grid, OS%GV, OS%US, param_file, OS%Waves, OS%diag) + call get_param(param_file,mdl,"SURFBAND_WAVENUMBERS",OS%Waves%WaveNum_Cen, & + "Central wavenumbers for surface Stokes drift bands.",units='rad/m', & + default=0.12566) else call MOM_wave_interface_init_lite(param_file) endif @@ -570,7 +573,7 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, & call set_net_mass_forcing(OS%fluxes, OS%forces, OS%grid, OS%US) if (OS%use_waves) then - call Update_Surface_Waves(OS%grid, OS%GV, OS%US, OS%time, ocean_coupling_time_step, OS%waves) + call Update_Surface_Waves(OS%grid, OS%GV, OS%US, OS%time, ocean_coupling_time_step, OS%waves, OS%forces) endif if (OS%nstep==0) then diff --git a/config_src/nuopc_driver/mom_surface_forcing_nuopc.F90 b/config_src/nuopc_driver/mom_surface_forcing_nuopc.F90 index 7f729e3c3e..7714793e42 100644 --- a/config_src/nuopc_driver/mom_surface_forcing_nuopc.F90 +++ b/config_src/nuopc_driver/mom_surface_forcing_nuopc.F90 @@ -181,9 +181,15 @@ module MOM_surface_forcing_nuopc !! ice-shelves, expressed as a coefficient !! for divergence damping, as determined !! outside of the ocean model in [m3/s] + real, pointer, dimension(:,:) :: ustk0 => NULL() !< + real, pointer, dimension(:,:) :: vstk0 => NULL() !< + real, pointer, dimension(:) :: stk_wavenumbers => NULL() !< + real, pointer, dimension(:,:,:) :: ustkb => NULL() !< + real, pointer, dimension(:,:,:) :: vstkb => NULL() !< + integer :: num_stk_bands !< Number of Stokes drift bands passed through the coupler 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. + !! namedfields 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 @@ -619,7 +625,7 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS) 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 :: i, j, is, ie, js, je, Isq, Ieq, Jsq, Jeq, i0, j0, istk integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB, isr, ier, jsr, jer integer :: isc_bnd, iec_bnd, jsc_bnd, jec_bnd @@ -658,6 +664,7 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS) 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) @@ -668,6 +675,9 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS) if (associated(forces%rigidity_ice_u)) forces%rigidity_ice_u(:,:) = 0.0 if (associated(forces%rigidity_ice_v)) forces%rigidity_ice_v(:,:) = 0.0 + if ( associated(IOB%ustkb) ) & + call allocate_mech_forcing(G, forces, waves=.true., num_stk_bands=IOB%num_stk_bands) + ! applied surface pressure from atmosphere and cryosphere if (CS%use_limited_P_SSH) then forces%p_surf_SSH => forces%p_surf @@ -825,6 +835,24 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS) endif ! endif for wind related fields + ! wave to ocean coupling + if ( associated(IOB%ustkb) ) then + + forces%stk_wavenumbers(:) = IOB%stk_wavenumbers + do j=js,je; do i=is,ie + forces%ustk0(i,j) = IOB%ustk0(i-I0,j-J0) ! How to be careful here that the domains are right? + forces%vstk0(i,j) = IOB%vstk0(i-I0,j-J0) + enddo ; enddo + call pass_vector(forces%ustk0,forces%vstk0, G%domain ) + do istk = 1,IOB%num_stk_bands + do j=js,je; do i=is,ie + forces%ustkb(i,j,istk) = IOB%ustkb(i-I0,j-J0,istk) + forces%vstkb(i,j,istk) = IOB%vstkb(i-I0,j-J0,istk) + enddo; enddo + call pass_vector(forces%ustkb(:,:,istk),forces%vstkb(:,:,istk), G%domain ) + enddo + endif + ! sea ice related dynamic fields if (associated(IOB%ice_rigidity)) then call pass_var(rigidity_at_h, G%Domain, halo=1) diff --git a/src/core/MOM_forcing_type.F90 b/src/core/MOM_forcing_type.F90 index 3dd3af8fbf..699709722d 100644 --- a/src/core/MOM_forcing_type.F90 +++ b/src/core/MOM_forcing_type.F90 @@ -230,6 +230,15 @@ module MOM_forcing_type !! ice needs to be accumulated, and the rigidity explicitly !! reset to zero at the driver level when appropriate. + real, pointer, dimension(:,:) :: & + ustk0 => NULL(), & + vstk0 => NULL() + real, pointer, dimension(:) :: & + stk_wavenumbers => NULL() + real, pointer, dimension(:,:,:) :: & + ustkb => NULL(), & + vstkb => NULL() + logical :: initialized = .false. !< This indicates whether the appropriate arrays have been initialized. end type mech_forcing @@ -2875,7 +2884,7 @@ subroutine allocate_forcing_type(G, fluxes, water, heat, ustar, press, shelf, ic end subroutine allocate_forcing_type !> Conditionally allocate fields within the mechanical forcing type -subroutine allocate_mech_forcing(G, forces, stress, ustar, shelf, press, iceberg) +subroutine allocate_mech_forcing(G, forces, stress, ustar, shelf, press, iceberg, waves, num_stk_bands) type(ocean_grid_type), intent(in) :: G !< Ocean grid structure type(mech_forcing), intent(inout) :: forces !< Forcing fields structure @@ -2884,6 +2893,8 @@ subroutine allocate_mech_forcing(G, forces, stress, ustar, shelf, press, iceberg logical, optional, intent(in) :: shelf !< If present and true, allocate forces for ice-shelf logical, optional, intent(in) :: press !< If present and true, allocate p_surf and related fields logical, optional, intent(in) :: iceberg !< If present and true, allocate forces for icebergs + logical, optional, intent(in) :: waves !< If present and true, allocate wave fields + integer, optional, intent(in) :: num_stk_bands !< Number of Stokes bands to allocate ! Local variables integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB @@ -2910,6 +2921,18 @@ subroutine allocate_mech_forcing(G, forces, stress, ustar, shelf, press, iceberg call myAlloc(forces%area_berg,isd,ied,jsd,jed, iceberg) call myAlloc(forces%mass_berg,isd,ied,jsd,jed, iceberg) + !These fields should only be allocated when waves are being passed through the coupler + call myAlloc(forces%ustk0,isd,ied,jsd,jed, waves) + call myAlloc(forces%vstk0,isd,ied,jsd,jed, waves) + if (present(waves)) then; if (waves) then; if (.not.associated(forces%ustkb)) then + if (.not.(present(num_stk_bands))) call MOM_error(FATAL,"Requested to initialize with waves, but no waves are present.") + allocate(forces%stk_wavenumbers(num_stk_bands)) ; forces%stk_wavenumbers (:) = 0.0 + allocate(forces%ustkb(isd:ied,jsd:jed,num_stk_bands)) ; forces%ustkb(isd:ied,jsd:jed,:) = 0.0 + endif; endif; endif + if (present(waves)) then; if (waves) then; if (.not.associated(forces%vstkb)) then + allocate(forces%vstkb(isd:ied,jsd:jed,num_stk_bands)) ; forces%vstkb(isd:ied,jsd:jed,:) = 0.0 + endif; endif; endif + end subroutine allocate_mech_forcing !> Allocates and zeroes-out array. diff --git a/src/user/MOM_wave_interface.F90 b/src/user/MOM_wave_interface.F90 index 46aced3127..23c9c3a678 100644 --- a/src/user/MOM_wave_interface.F90 +++ b/src/user/MOM_wave_interface.F90 @@ -9,6 +9,7 @@ module MOM_wave_interface 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_forcing_type, only : mech_forcing use MOM_grid, only : ocean_grid_type use MOM_safe_alloc, only : safe_alloc_ptr use MOM_time_manager, only : time_type, operator(+), operator(/) @@ -68,6 +69,9 @@ module MOM_wave_interface !! approach. ! Surface Wave Dependent 1d/2d/3d vars + 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. real, allocatable, dimension(:), public :: & WaveNum_Cen !< Wavenumber bands for read/coupled [m-1] real, allocatable, dimension(:), public :: & @@ -138,10 +142,6 @@ module MOM_wave_interface !! \todo Module variable! Move into a control structure. ! 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. - !! \todo Module variable! Move into a control structure. integer, public :: PartitionMode !< Method for partition mode (meant to check input) !! 0 - wavenumbers !! 1 - frequencies @@ -300,22 +300,34 @@ subroutine MOM_wave_interface_init(time, G, GV, US, param_file, CS, diag ) "Filename of surface Stokes drift input band data.", default="StkSpec.nc") case (COUPLER_STRING)! Reserved for coupling DataSource = Coupler + ! This is just to make something work, but it needs to be read from the wavemodel. + call get_param(param_file,mdl,"STK_BAND_COUPLER",CS%NumBands, & + "STK_BAND_COUPLER is the number of Stokes drift bands in the coupler. "// & + "This has to be consistent with the number of Stokes drift bands in WW3, "//& + "or the model will fail.",units='', default=1) + allocate( CS%WaveNum_Cen(CS%NumBands) ) + allocate( CS%STKx0(G%isdB:G%iedB,G%jsd:G%jed,CS%NumBands)) + allocate( CS%STKy0(G%isdB:G%iedB,G%jsd:G%jed,CS%NumBands)) + CS%WaveNum_Cen(:) = 0.0 + CS%STKx0(:,:,:) = 0.0 + CS%STKy0(:,:,:) = 0.0 + partitionmode = 0 case (INPUT_STRING)! A method to input the Stokes band (globally uniform) DataSource = Input - call get_param(param_file,mdl,"SURFBAND_NB",NumBands, & + call get_param(param_file,mdl,"SURFBAND_NB",CS%NumBands, & "Prescribe number of wavenumber bands for Stokes drift. "// & "Make sure this is consistnet w/ WAVENUMBERS, STOKES_X, and "// & "STOKES_Y, there are no safety checks in the code.", & units='', default=1) - allocate( CS%WaveNum_Cen(1:NumBands) ) + allocate( CS%WaveNum_Cen(1:CS%NumBands) ) CS%WaveNum_Cen(:) = 0.0 - allocate( CS%PrescribedSurfStkX(1:NumBands)) + allocate( CS%PrescribedSurfStkX(1:CS%NumBands)) CS%PrescribedSurfStkX(:) = 0.0 - allocate( CS%PrescribedSurfStkY(1:NumBands)) + allocate( CS%PrescribedSurfStkY(1:CS%NumBands)) CS%PrescribedSurfStkY(:) = 0.0 - allocate( CS%STKx0(G%isdB:G%iedB,G%jsd:G%jed,1:NumBands)) + allocate( CS%STKx0(G%isdB:G%iedB,G%jsd:G%jed,1:CS%NumBands)) CS%STKx0(:,:,:) = 0.0 - allocate( CS%STKy0(G%isd:G%ied,G%jsdB:G%jedB,1:NumBands)) + allocate( CS%STKy0(G%isd:G%ied,G%jsdB:G%jedB,1:CS%NumBands)) CS%STKy0(:,:,:) = 0.0 partitionmode=0 call get_param(param_file,mdl,"SURFBAND_WAVENUMBERS",CS%WaveNum_Cen, & @@ -433,13 +445,14 @@ subroutine MOM_wave_interface_init_lite(param_file) end subroutine MOM_wave_interface_init_lite !> Subroutine that handles updating of surface wave/Stokes drift related properties -subroutine Update_Surface_Waves(G, GV, US, Day, dt, CS) +subroutine Update_Surface_Waves(G, GV, US, Day, dt, CS, forces) 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(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(time_type), intent(in) :: Day !< Current model time type(time_type), intent(in) :: dt !< Timestep as a time-type + type(mech_forcing), intent(in) :: forces !< MOM_forcing_type ! Local variables integer :: ii, jj, kk, b type(time_type) :: Day_Center @@ -453,9 +466,29 @@ subroutine Update_Surface_Waves(G, GV, US, Day, dt, CS) if (DataSource==DATAOVR) then call Surface_Bands_by_data_override(day_center, G, GV, US, CS) elseif (DataSource==Coupler) then - ! Reserve for coupler hooks + if (size(CS%WaveNum_Cen).ne.size(forces%stk_wavenumbers)) then + call MOM_error(FATAL, "Number of wavenumber bands in WW3 does not match that in MOM6. "//& + "Make sure that STK_BAND_COUPLER in MOM6 input is equal to the number of bands in "//& + "ww3_grid.inp, and that your mod_def.ww3 is up to date.") + endif + + do b=1,CS%NumBands + CS%WaveNum_Cen(b) = forces%stk_wavenumbers(b) + !Interpolate from a grid to c grid + do II=G%iscB,G%iecB + do jj=G%jsc,G%jec + CS%STKx0(II,jj,b) = 0.5*(forces%UStkb(ii,jj,b)+forces%UStkb(ii+1,jj,b)) + enddo + enddo + do ii=G%isc,G%iec + do JJ=G%jscB, G%jecB + CS%STKY0(ii,JJ,b) = 0.5*(forces%VStkb(ii,jj,b)+forces%VStkb(ii,jj+1,b)) + enddo + enddo + call pass_vector(CS%STKx0(:,:,b),CS%STKy0(:,:,b), G%Domain) + enddo elseif (DataSource==Input) then - do b=1,NumBands + do b=1,CS%NumBands do II=G%isdB,G%iedB do jj=G%jsd,G%jed CS%STKx0(II,jj,b) = CS%PrescribedSurfStkX(b) @@ -485,13 +518,14 @@ subroutine Update_Stokes_Drift(G, GV, US, CS, h, ustar) real, dimension(SZI_(G),SZJ_(G)), & intent(in) :: ustar !< Wind friction velocity [Z T-1 ~> m s-1]. ! Local Variables - real :: Top, MidPoint, Bottom, one_cm + real :: Top, MidPoint, Bottom, one_cm, level_thick, min_level_thick_avg real :: DecayScale real :: CMN_FAC, WN, UStokes real :: La integer :: ii, jj, kk, b, iim1, jjm1 one_cm = 0.01*US%m_to_Z + min_level_thick_avg = 1.e-3*US%m_to_Z ! 1. If Test Profile Option is chosen ! Computing mid-point value from surface value and decay wavelength @@ -536,7 +570,7 @@ subroutine Update_Stokes_Drift(G, GV, US, CS, h, ustar) do jj = G%jsd,G%jed ! 1. First compute the surface Stokes drift ! by integrating over the partitionas. - do b = 1,NumBands + do b = 1,CS%NumBands if (PartitionMode==0) then ! In wavenumber we are averaging over (small) level CMN_FAC = (1.0-exp(-one_cm*2.*CS%WaveNum_Cen(b))) / & @@ -552,26 +586,40 @@ subroutine Update_Stokes_Drift(G, GV, US, CS, h, ustar) do kk = 1,G%ke Top = Bottom IIm1 = max(II-1,1) - MidPoint = Bottom - GV%H_to_Z*0.25*(h(II,jj,kk)+h(IIm1,jj,kk)) - Bottom = Bottom - GV%H_to_Z*0.5*(h(II,jj,kk)+h(IIm1,jj,kk)) - do b = 1,NumBands - if (PartitionMode==0) then + level_thick = 0.5*GV%H_to_Z*(h(II,jj,kk)+h(IIm1,jj,kk)) + MidPoint = Bottom - 0.5*level_thick + Bottom = Bottom - level_thick + ! -> Stokes drift in thin layers not averaged. + if (level_thick>min_level_thick_avg) then + do b = 1,CS%NumBands + if (PartitionMode==0) then ! In wavenumber we are averaging over level - CMN_FAC = (exp(Top*2.*CS%WaveNum_Cen(b))-exp(Bottom*2.*CS%WaveNum_Cen(b)))& - / ((Top-Bottom)*(2.*CS%WaveNum_Cen(b))) - elseif (PartitionMode==1) then - if (CS%StkLevelMode==0) then - ! Take the value at the midpoint - CMN_FAC = exp(MidPoint*2.*(2.*PI*CS%Freq_Cen(b)*US%T_to_s)**2/(US%L_to_Z**2*GV%g_Earth)) - elseif (CS%StkLevelMode==1) then - ! Use a numerical integration and then - ! divide by layer thickness - WN = (2.*PI*CS%Freq_Cen(b)*US%T_to_s)**2 / (US%L_to_Z**2*GV%g_Earth) !bgr bug-fix missing g - CMN_FAC = (exp(2.*WN*Top)-exp(2.*WN*Bottom)) / (2.*WN*(Top-Bottom)) + CMN_FAC = (exp(Top*2.*CS%WaveNum_Cen(b))-exp(Bottom*2.*CS%WaveNum_Cen(b)))& + / ((Top-Bottom)*(2.*CS%WaveNum_Cen(b))) + elseif (PartitionMode==1) then + if (CS%StkLevelMode==0) then + ! Take the value at the midpoint + CMN_FAC = exp(MidPoint*2.*(2.*PI*CS%Freq_Cen(b)*US%T_to_s)**2/(US%L_to_Z**2*GV%g_Earth)) + elseif (CS%StkLevelMode==1) then + ! Use a numerical integration and then + ! divide by layer thickness + WN = (2.*PI*CS%Freq_Cen(b)*US%T_to_s)**2 / (US%L_to_Z**2*GV%g_Earth) !bgr bug-fix missing g + CMN_FAC = (exp(2.*WN*Top)-exp(2.*WN*Bottom)) / (2.*WN*(Top-Bottom)) + endif endif - endif - CS%US_x(II,jj,kk) = CS%US_x(II,jj,kk) + CS%STKx0(II,jj,b)*CMN_FAC - enddo + CS%US_x(II,jj,kk) = CS%US_x(II,jj,kk) + CS%STKx0(II,jj,b)*CMN_FAC + enddo + else + ! Take the value at the midpoint + do b = 1,CS%NumBands + if (PartitionMode==0) then + CMN_FAC = exp(MidPoint*2.*CS%WaveNum_Cen(b)) + elseif (PartitionMode==1) then + CMN_FAC = exp(MidPoint*2.*(2.*PI*CS%Freq_Cen(b)*US%T_to_s)**2/(US%L_to_Z**2*GV%g_Earth)) + endif + CS%US_x(II,jj,kk) = CS%US_x(II,jj,kk) + CS%STKx0(II,jj,b)*CMN_FAC + enddo + endif enddo enddo enddo @@ -579,7 +627,7 @@ subroutine Update_Stokes_Drift(G, GV, US, CS, h, ustar) do ii = G%isd,G%ied do JJ = G%jsdB,G%jedB ! Compute the surface values. - do b = 1,NumBands + do b = 1,CS%NumBands if (PartitionMode==0) then ! In wavenumber we are averaging over (small) level CMN_FAC = (1.0-exp(-one_cm*2.*CS%WaveNum_Cen(b))) / & @@ -595,27 +643,40 @@ subroutine Update_Stokes_Drift(G, GV, US, CS, h, ustar) do kk = 1,G%ke Top = Bottom JJm1 = max(JJ-1,1) - MidPoint = Bottom - GV%H_to_Z*0.25*(h(ii,JJ,kk)+h(ii,JJm1,kk)) - Bottom = Bottom - GV%H_to_Z*0.5*(h(ii,JJ,kk)+h(ii,JJm1,kk)) - do b = 1,NumBands - if (PartitionMode==0) then + level_thick = 0.5*GV%H_to_Z*(h(ii,JJ,kk)+h(ii,JJm1,kk)) + MidPoint = Bottom - 0.5*level_thick + Bottom = Bottom - level_thick + ! -> Stokes drift in thin layers not averaged. + if (level_thick>min_level_thick_avg) then + do b = 1,CS%NumBands + if (PartitionMode==0) then ! In wavenumber we are averaging over level - CMN_FAC = (exp(Top*2.*CS%WaveNum_Cen(b)) - & - exp(Bottom*2.*CS%WaveNum_Cen(b))) / & - ((Top-Bottom)*(2.*CS%WaveNum_Cen(b))) - elseif (PartitionMode==1) then - if (CS%StkLevelMode==0) then - ! Take the value at the midpoint - CMN_FAC = exp(MidPoint*2.*(2.*PI*CS%Freq_Cen(b)*US%T_to_s)**2/(US%L_to_Z**2*GV%g_Earth)) - elseif (CS%StkLevelMode==1) then - ! Use a numerical integration and then - ! divide by layer thickness - WN = (2.*PI*CS%Freq_Cen(b)*US%T_to_s)**2 / (US%L_to_Z**2*GV%g_Earth) - CMN_FAC = (exp(2.*WN*Top)-exp(2.*WN*Bottom)) / (2.*WN*(Top-Bottom)) + CMN_FAC = (exp(Top*2.*CS%WaveNum_Cen(b))-exp(Bottom*2.*CS%WaveNum_Cen(b)))& + / ((Top-Bottom)*(2.*CS%WaveNum_Cen(b))) + elseif (PartitionMode==1) then + if (CS%StkLevelMode==0) then + ! Take the value at the midpoint + CMN_FAC = exp(MidPoint*2.*(2.*PI*CS%Freq_Cen(b)*US%T_to_s)**2/(US%L_to_Z**2*GV%g_Earth)) + elseif (CS%StkLevelMode==1) then + ! Use a numerical integration and then + ! divide by layer thickness + WN = (2.*PI*CS%Freq_Cen(b)*US%T_to_s)**2 / (US%L_to_Z**2*GV%g_Earth) !bgr bug-fix missing g + CMN_FAC = (exp(2.*WN*Top)-exp(2.*WN*Bottom)) / (2.*WN*(Top-Bottom)) + endif endif - endif - CS%US_y(ii,JJ,kk) = CS%US_y(ii,JJ,kk) + CS%STKy0(ii,JJ,b)*CMN_FAC - enddo + CS%US_y(ii,JJ,kk) = CS%US_y(ii,JJ,kk) + CS%STKy0(ii,JJ,b)*CMN_FAC + enddo + else + ! Take the value at the midpoint + do b = 1,CS%NumBands + if (PartitionMode==0) then + CMN_FAC = exp(MidPoint*2.*CS%WaveNum_Cen(b)) + elseif (PartitionMode==1) then + CMN_FAC = exp(MidPoint*2.*(2.*PI*CS%Freq_Cen(b)*US%T_to_s)**2/(US%L_to_Z**2*GV%g_Earth)) + endif + CS%US_y(ii,JJ,kk) = CS%US_y(ii,JJ,kk) + CS%STKy0(ii,JJ,b)*CMN_FAC + enddo + endif enddo enddo enddo @@ -812,8 +873,8 @@ subroutine Surface_Bands_by_data_override(day_center, G, GV, US, CS) trim(varread1)//",dim_name "//trim(dim_name(1))// & " in file "// trim(SurfBandFileName)//" in MOM_wave_interface") endif - NUMBANDS = ID - do B = 1,NumBands ; CS%WaveNum_Cen(b) = US%Z_to_m*CS%WaveNum_Cen(b) ; enddo + CS%NUMBANDS = ID + do B = 1,CS%NumBands ; CS%WaveNum_Cen(b) = US%Z_to_m*CS%WaveNum_Cen(b) ; enddo elseif (PartitionMode==1) then rcode_fr = NF90_GET_VAR(ncid, dim_id(1), CS%Freq_Cen, start, counter) if (rcode_fr /= 0) then @@ -822,15 +883,15 @@ subroutine Surface_Bands_by_data_override(day_center, G, GV, US, CS) trim(varread2)//",dim_name "//trim(dim_name(1))// & " in file "// trim(SurfBandFileName)//" in MOM_wave_interface") endif - NUMBANDS = ID - do B = 1,NumBands + CS%NUMBANDS = ID + do B = 1,CS%NumBands CS%WaveNum_Cen(b) = (2.*PI*CS%Freq_Cen(b)*US%T_to_s)**2 / (US%L_to_Z**2*GV%g_Earth) enddo endif endif - do b = 1,NumBands + do b = 1,CS%NumBands temp_x(:,:) = 0.0 temp_y(:,:) = 0.0 varname = ' ' @@ -904,9 +965,10 @@ subroutine get_Langmuir_Number( LA, G, GV, US, HBL, ustar, i, j, & real :: LA_STKx, LA_STKy, LA_STK ! Stokes velocities in [m s-1] logical :: ContinueLoop, USE_MA real, dimension(SZK_(G)) :: US_H, VS_H - real, dimension(NumBands) :: StkBand_X, StkBand_Y + real, allocatable :: StkBand_X(:), StkBand_Y(:) integer :: KK, BB + ! Compute averaging depth for Stokes drift (negative) Dpt_LASL = min(-0.1*US%m_to_Z, -LA_FracHBL*HBL) @@ -940,13 +1002,15 @@ subroutine get_Langmuir_Number( LA, G, GV, US, HBL, ustar, i, j, & call Get_SL_Average_Prof( GV, Dpt_LASL, H, VS_H, LA_STKy) LA_STK = sqrt(LA_STKX*LA_STKX+LA_STKY*LA_STKY) elseif (WaveMethod==SURFBANDS) then - do bb = 1,NumBands + allocate(StkBand_X(WAVES%NumBands), StkBand_Y(WAVES%NumBands)) + do bb = 1,WAVES%NumBands StkBand_X(bb) = 0.5*(WAVES%STKx0(I,j,bb)+WAVES%STKx0(I-1,j,bb)) StkBand_Y(bb) = 0.5*(WAVES%STKy0(i,J,bb)+WAVES%STKy0(i,J-1,bb)) enddo - call Get_SL_Average_Band(GV, Dpt_LASL, NumBands, WAVES%WaveNum_Cen, StkBand_X, LA_STKx ) - call Get_SL_Average_Band(GV, Dpt_LASL, NumBands, WAVES%WaveNum_Cen, StkBand_Y, LA_STKy ) + call Get_SL_Average_Band(GV, Dpt_LASL, WAVES%NumBands, WAVES%WaveNum_Cen, StkBand_X, LA_STKx ) + call Get_SL_Average_Band(GV, Dpt_LASL, WAVES%NumBands, WAVES%WaveNum_Cen, StkBand_Y, LA_STKy ) LA_STK = sqrt(LA_STKX**2 + LA_STKY**2) + deallocate(StkBand_X, StkBand_Y) elseif (WaveMethod==DHH85) then ! Temporarily integrating profile rather than spectrum for simplicity do kk = 1,GV%ke From 4b33dd03250c1e9e8d1c126c82c36e89b4f9e3d9 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 13 May 2020 18:46:40 -0400 Subject: [PATCH 280/316] (*)Corrected PPM_angular_advect Corrected the negative CFL branch of PPM_angular_advect in MOM_internal_tides. Simultaneously there was some revision to match other equivalent PPM advection schemes in the MOM6 code and to replace some divisions by a multiplication by a reciprocal. The previous version was sufficiently wrong that it could not ever have been used in any scientifically meaningful solutions, including anything in MOM6-examples. Accordingly, the PPM_angular_advect code was changed without a flag to retain the previous answers. All answers in the MOM6-examples test cases are bitwise identical, and output files are unchanged. --- .../lateral/MOM_internal_tides.F90 | 49 +++++++++---------- 1 file changed, 23 insertions(+), 26 deletions(-) diff --git a/src/parameterizations/lateral/MOM_internal_tides.F90 b/src/parameterizations/lateral/MOM_internal_tides.F90 index 6145fb1dce..a0f1631d6d 100644 --- a/src/parameterizations/lateral/MOM_internal_tides.F90 +++ b/src/parameterizations/lateral/MOM_internal_tides.F90 @@ -894,7 +894,8 @@ subroutine PPM_angular_advect(En2d, CFL_ang, Flux_En, NAngle, dt, halo_ang) real :: dMx, dMn real :: Ep, Ec, Em ! Mean angular energy density for three successive wedges in angular ! orientation [R Z3 T-2 rad-1 ~> J m-2 rad-1] - real :: dA, mA, a6 ! Difference, mean, and curvature of energy density [R Z3 T-2 rad-1 ~> J m-2 rad-1] + real :: dA, curv_3 ! Difference and curvature of energy density [R Z3 T-2 rad-1 ~> J m-2 rad-1] + real, parameter :: oneSixth = 1.0/6.0 ! One sixth [nondim] integer :: a I_dt = 1 / dt @@ -912,23 +913,21 @@ subroutine PPM_angular_advect(En2d, CFL_ang, Flux_En, NAngle, dt, halo_ang) Ec = En2d(a) *I_Angle_size Em = En2d(a-1)*I_Angle_size ! Calculate and bound edge values of energy density. - aL = ( 5.*Ec + ( 2.*Em - Ep ) )/6. ! H3 estimate + aL = ( 5.*Ec + ( 2.*Em - Ep ) ) * oneSixth ! H3 estimate aL = max( min(Ec,Em), aL) ; aL = min( max(Ec,Em), aL) ! Bound - aR = ( 5.*Ec + ( 2.*Ep - Em ) )/6. ! H3 estimate + aR = ( 5.*Ec + ( 2.*Ep - Em ) ) * oneSixth ! H3 estimate aR = max( min(Ec,Ep), aR) ; aR = min( max(Ec,Ep), aR) ! Bound - dA = aR - aL ; mA = 0.5*( aR + aL ) + dA = aR - aL if ((Ep-Ec)*(Ec-Em) <= 0.) then - aL = Ec ; aR = Ec ! PCM for local extremum - elseif ( dA*(Ec-mA) > (dA*dA)/6. ) then - aL = 3.*Ec - 2.*aR !? - elseif ( dA*(Ec-mA) < - (dA*dA)/6. ) then - aR = 3.*Ec - 2.*aL !? + aL = Ec ; aR = Ec ! use PCM for local extremum + elseif ( 3.0*dA*(2.*Ec - (aR + aL)) > (dA*dA) ) then + aL = 3.*Ec - 2.*aR ! Flatten the profile to move the extremum to the left edge + elseif ( 3.0*dA*(2.*Ec - (aR + aL)) < - (dA*dA) ) then + aR = 3.*Ec - 2.*aL ! Flatten the profile to move the extremum to the right edge endif - a6 = 6.*Ec - 3. * (aR + aL) ! Curvature + curv_3 = (aR + aL) - 2.0*Ec ! Curvature ! Calculate angular flux rate [R Z3 T-3 ~> W m-2] - flux = u_ang*( aR + 0.5 * CFL_ang(A) * ( ( aL - aR ) + a6 * ( 1. - 2./3. * CFL_ang(A) ) ) ) - ! The following expression copied from tracer_advect is equivalent. - ! flux = u_ang*( aR - 0.5 * CFL_ang(A) * ( ( aR - aL ) - a6 * ( 1. - 2./3. * CFL_ang(A) ) ) ) + flux = u_ang*( aR + CFL_ang(A) * ( 0.5*(aL - aR) + curv_3 * (CFL_ang(A) - 1.5) ) ) ! Calculate amount of energy fluxed between wedges [R Z3 T-2 ~> J m-2] Flux_En(A) = dt * flux !Flux_En(A) = (dt * I_Angle_size) * flux @@ -940,24 +939,22 @@ subroutine PPM_angular_advect(En2d, CFL_ang, Flux_En, NAngle, dt, halo_ang) Ec = En2d(a+1)*I_Angle_size Em = En2d(a) *I_Angle_size ! Calculate and bound edge values of energy density. - aL = ( 5.*Ec + ( 2.*Em - Ep ) )/6. ! H3 estimate + aL = ( 5.*Ec + ( 2.*Em - Ep ) ) * oneSixth ! H3 estimate aL = max( min(Ec,Em), aL) ; aL = min( max(Ec,Em), aL) ! Bound - aR = ( 5.*Ec + ( 2.*Ep - Em ) )/6. ! H3 estimate + aR = ( 5.*Ec + ( 2.*Ep - Em ) ) * oneSixth ! H3 estimate aR = max( min(Ec,Ep), aR) ; aR = min( max(Ec,Ep), aR) ! Bound - dA = aR - aL ; mA = 0.5*( aR + aL ) + dA = aR - aL if ((Ep-Ec)*(Ec-Em) <= 0.) then - aL = Ec ; aR = Ec ! PCM for local extremum - elseif ( dA*(Ec-mA) > (dA*dA)/6. ) then - aL = 3.*Ec - 2.*aR - elseif ( dA*(Ec-mA) < - (dA*dA)/6. ) then - aR = 3.*Ec - 2.*aL + aL = Ec ; aR = Ec ! use PCM for local extremum + elseif ( 3.0*dA*(2.*Ec - (aR + aL)) > (dA*dA) ) then + aL = 3.*Ec - 2.*aR ! Flatten the profile to move the extremum to the left edge + elseif ( 3.0*dA*(2.*Ec - (aR + aL)) < - (dA*dA) ) then + aR = 3.*Ec - 2.*aL ! Flatten the profile to move the extremum to the right edge endif - a6 = 6.*Ec - 3. * (aR + aL) ! Curvature + curv_3 = (aR + aL) - 2.0*Ec ! Curvature ! Calculate angular flux rate [R Z3 T-3 ~> W m-2] - !### This expression is wrong, because it was just copied from above. The correct one is below - flux = u_ang*( aR + 0.5 * CFL_ang(A) * ( ( aL - aR ) + a6 * ( 1. - 2./3. * CFL_ang(A) ) ) ) - ! This is the correct expression; note that CFL_ang is negative here, so it looks a bit odd. - !flux = u_ang*( aL - 0.5 * CFL_ang(A) * ( ( aR - aL ) + a6 * ( 1. + 2./3. * CFL_ang(A) ) ) ) + ! Note that CFL_ang is negative here, so it looks odd compared with equivalent expressions. + flux = u_ang*( aL - CFL_ang(A) * ( 0.5*(aR - aL) + curv_3 * (-CFL_ang(A) - 1.5) ) ) ! Calculate amount of energy fluxed between wedges [R Z3 T-2 ~> J m-2] Flux_En(A) = dt * flux !Flux_En(A) = (dt * I_Angle_size) * flux From 435fa9b3a3bd4389a521f4dddfa9c6244ba92763 Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Thu, 14 May 2020 15:52:45 -0400 Subject: [PATCH 281/316] Makefile: reduced logging, -k support The Makefile has been modified to reduce the amount of output during testing. Output is generally omitted on a successful test. When a test fails, we only display a small portion of the total output. We also now run all tests, even if they fail, in order to give a complete profile of the test failures. Regression testing rules have been integrated into the general rules. Finally, Travis config has been modified to further reduce output, and to run all of tests (make -k). --- .testing/Makefile | 212 +++++++++++++++++++++++++++++----------------- .travis.yml | 5 +- 2 files changed, 137 insertions(+), 80 deletions(-) diff --git a/.testing/Makefile b/.testing/Makefile index 99672268c3..f0ecb09a0a 100644 --- a/.testing/Makefile +++ b/.testing/Makefile @@ -119,28 +119,28 @@ build/%/MOM6: build/%/Makefile $(FMS)/lib/libfms.a build/%/Makefile: build/%/path_names cp $(MKMF_TEMPLATE) $(@D) cd $(@D) && $(MKMF) \ - -t $(notdir $(MKMF_TEMPLATE)) \ - -o '-I ../../$(DEPS)/fms/build' \ - -p MOM6 \ - -l '../../$(DEPS)/fms/lib/libfms.a' \ - -c $(MKMF_CPP) \ - path_names + -t $(notdir $(MKMF_TEMPLATE)) \ + -o '-I ../../$(DEPS)/fms/build' \ + -p MOM6 \ + -l '../../$(DEPS)/fms/lib/libfms.a' \ + -c $(MKMF_CPP) \ + path_names # NOTE: These path_names rules could be merged build/target/path_names: $(LIST_PATHS) $(TARGET_CODEBASE) $(TARGET_SOURCE) mkdir -p $(@D) cd $(@D) && $(LIST_PATHS) -l \ - ../../$(TARGET_CODEBASE)/src \ - ../../$(TARGET_CODEBASE)/config_src/solo_driver \ - ../../$(TARGET_CODEBASE)/$(GRID_SRC) + ../../$(TARGET_CODEBASE)/src \ + ../../$(TARGET_CODEBASE)/config_src/solo_driver \ + ../../$(TARGET_CODEBASE)/$(GRID_SRC) build/%/path_names: $(LIST_PATHS) $(MOM_SOURCE) mkdir -p $(@D) cd $(@D) && $(LIST_PATHS) -l \ - ../../../src \ - ../../../config_src/solo_driver \ - ../../../$(GRID_SRC) + ../../../src \ + ../../../config_src/solo_driver \ + ../../../$(GRID_SRC) # Target repository for regression tests $(TARGET_CODEBASE): @@ -158,10 +158,10 @@ $(FMS)/lib/libfms.a: $(FMS)/build/Makefile $(FMS)/build/Makefile: $(FMS)/build/path_names cp $(MKMF_TEMPLATE) $(@D) cd $(@D) && $(MKMF) \ - -t $(notdir $(MKMF_TEMPLATE)) \ - -p ../lib/libfms.a \ - -c $(MKMF_CPP) \ - path_names + -t $(notdir $(MKMF_TEMPLATE)) \ + -p ../lib/libfms.a \ + -c $(MKMF_CPP) \ + path_names $(FMS)/build/path_names: $(LIST_PATHS) $(FMS)/src $(FMS_SOURCE) mkdir -p $(@D) @@ -202,18 +202,38 @@ test.repros: $(foreach c,$(CONFIGS),$(c).repro $(c).repro.diag) test.openmps: $(foreach c,$(CONFIGS),$(c).openmp $(c).openmp.diag) test.nans: $(foreach c,$(CONFIGS),$(c).nan $(c).nan.diag) test.dims: $(foreach c,$(CONFIGS),$(foreach d,$(DIMS),$(c).dim.$(d) $(c).dim.$(d).diag)) - test.regressions: $(foreach c,$(CONFIGS),$(c).regression $(c).regression.diag) - ! ls -1 results/*/*.reg -define CMP_RULE -.PRECIOUS: $(foreach b,$(2),results/%/ocean.stats.$(b)) -%.$(1): $(foreach b,$(2),results/%/ocean.stats.$(b)) - cmp $$^ || diff $$^ +# Color highlights for test results +RED=\033[0;31m +GREEN=\033[0;32m +RESET=\033[0m + +DONE=${GREEN}DONE${RESET} +PASS=${GREEN}PASS${RESET} +FAIL=${RED}FAIL${RESET} -.PRECIOUS: $(foreach b,$(2),results/%/chksum_diag.$(b)) -%.$(1).diag: $(foreach b,$(2),results/%/chksum_diag.$(b)) - cmp $$^ || diff $$^ +# Comparison rules +# $(1): Test type (grid, layout, &c.) +# $(2): Comparison targets (symmetric asymmetric, symmetric layout, &c.) +define CMP_RULE +.PRECIOUS: $(foreach b,$(2),work/%/$(b)/ocean.stats) +%.$(1): $(foreach b,$(2),work/%/$(b)/ocean.stats) + @cmp $$^ || !( \ + mkdir -p results/$$*; \ + (diff $$^ | tee results/$$*/ocean.stats.$(1).diff | head) ; \ + echo -e "${FAIL}: Solutions $$*.$(1) have changed." \ + ) + @echo -e "${PASS}: Solutions $$*.$(1) agree." + +.PRECIOUS: $(foreach b,$(2),work/%/$(b)/chksum_diag) +%.$(1).diag: $(foreach b,$(2),work/%/$(b)/chksum_diag) + @cmp $$^ || !( \ + mkdir -p results/$$*; \ + (diff $$^ | tee results/$$*/chksum_diag.$(1).diff | head) ; \ + echo -e "${FAIL}: Diagnostics $$*.$(1).diag have changed." \ + ) + @echo -e "${PASS}: Diagnostics $$*.$(1).diag agree." endef $(eval $(call CMP_RULE,grid,symmetric asymmetric)) @@ -223,29 +243,31 @@ $(eval $(call CMP_RULE,repro,symmetric repro)) $(eval $(call CMP_RULE,openmp,symmetric openmp)) $(eval $(call CMP_RULE,nan,symmetric nan)) $(foreach d,$(DIMS),$(eval $(call CMP_RULE,dim.$(d),symmetric dim.$(d)))) +$(eval $(call CMP_RULE,regression,symmetric target)) # Custom comparison rules -.PRECIOUS: $(foreach b,symmetric restart target,results/%/ocean.stats.$(b)) - # Restart tests only compare the final stat record -%.restart: $(foreach b,symmetric restart,results/%/ocean.stats.$(b)) - cmp $(foreach f,$^,<(tr -s ' ' < $(f) | cut -d ' ' -f3- | tail -n 1)) \ - || diff $^ +.PRECIOUS: $(foreach b,symmetric restart target,work/%/$(b)/ocean.stats) +%.restart: $(foreach b,symmetric restart,work/%/$(b)/ocean.stats) + #cmp $(foreach f,$^,<(tr -s ' ' < $(f) | cut -d ' ' -f3- | tail -n 1)) \ + # || diff $^ + @cmp $(foreach f,$^,<(tr -s ' ' < $(f) | cut -d ' ' -f3- | tail -n 1)) \ + || !( \ + mkdir -p results/$*; \ + (diff $$^ | tee results/$*/chksum_diag.restart.diff | head) ; \ + echo -e "${FAIL}: Diagnostics $*.restart.diag have changed." \ + ) + @echo -e "${PASS}: Diagnostics $*.restart.diag agree." # TODO: chksum_diag parsing of restart files -# All regression tests must be completed when considering answer changes -%.regression: $(foreach b,symmetric target,results/%/ocean.stats.$(b)) - cmp $^ || (diff $^ > $<.reg || true) - -%.regression.diag: $(foreach b,symmetric target,results/%/chksum_diag.$(b)) - cmp $^ || (diff $^ > $<.reg || true) #--- # Test run output files # Generalized MPI environment variable support +# XXX: Using `-env` in the MPICH test can erroneously producing an `nv` file. # $(1): Environment variables ifeq ($(shell $(MPIRUN) -x tmp=1 true 2> /dev/null ; echo $$?), 0) MPIRUN_CMD=$(MPIRUN) $(if $(1),-x $(1),) @@ -255,7 +277,8 @@ else MPIRUN_CMD=$(1) $(MPIRUN) endif -# Rule to build results//{ocean.stats,chksum_diag}. + +# Rule to build work//{ocean.stats,chksum_diag}. # $(1): Test configuration name # $(2): Executable type # $(3): Enable coverage flag @@ -263,25 +286,28 @@ endif # $(5): Environment variables # $(6): Number of MPI ranks define STAT_RULE -results/%/ocean.stats.$(1): build/$(2)/MOM6 +work/%/$(1)/ocean.stats work/%/$(1)/chksum_diag: build/$(2)/MOM6 + @echo "Running test $$*.$(1)..." if [ $(3) ]; then find build/$(2) -name *.gcda -exec rm -f '{}' \; ; fi - mkdir -p work/$$*/$(1) - cp -rL $$*/* work/$$*/$(1) - cd work/$$*/$(1) && if [ -f Makefile ]; then make; fi - mkdir -p work/$$*/$(1)/RESTART - echo -e "$(4)" > work/$$*/$(1)/MOM_override - cd work/$$*/$(1) && $$(call MPIRUN_CMD,$(5)) -n $(6) ../../../$$< 2> debug.out > std.out \ - || ! sed 's/^/$$*.$(1): /' std.out debug.out \ - && sed 's/^/$$*.$(1): /' std.out mkdir -p $$(@D) - cp work/$$*/$(1)/ocean.stats $$@ + cp -rL $$*/* $$(@D) + cd $$(@D) && if [ -f Makefile ]; then make; fi + mkdir -p $$(@D)/RESTART + echo -e "$(4)" > $$(@D)/MOM_override + cd $$(@D) \ + && $$(call MPIRUN_CMD,$(5)) -n $(6) ../../../$$< 2> std.err > std.out \ + || !( \ + mkdir -p ../../../results/$$*/ ; \ + cat std.out | tee ../../../results/$$*/std.$(1).out | tail ; \ + cat std.err | tee ../../../results/$$*/std.$(1).err | tail ; \ + rm ocean.stats chksum_diag ; \ + echo -e "${FAIL}: $$*.$(1) failed at runtime." \ + ) + @echo -e "${DONE}: $$*.$(1); no runtime errors." if [ $(3) ]; then cd .. && bash <(curl -s https://codecov.io/bash) -n $$@; fi - -results/%/chksum_diag.$(1): results/%/ocean.stats.$(1) - mkdir -p $$(@D) - cp work/$$*/$(1)/chksum_diag $$@ endef + # Define $(,) as comma escape character , := , @@ -300,50 +326,80 @@ $(eval $(call STAT_RULE,dim.z,symmetric,,Z_RESCALE_POWER=11,,1)) $(eval $(call STAT_RULE,dim.q,symmetric,,Q_RESCALE_POWER=11,,1)) $(eval $(call STAT_RULE,dim.r,symmetric,,R_RESCALE_POWER=11,,1)) + # Restart tests require significant preprocessing, and are handled separately. -results/%/ocean.stats.restart: build/symmetric/MOM6 - rm -rf work/$*/restart - mkdir -p work/$*/restart - cp -rL $*/* work/$*/restart +work/%/restart/ocean.stats: build/symmetric/MOM6 + rm -rf $(@D) + mkdir -p $(@D) + cp -rL $*/* $(@D) cd work/$*/restart && if [ -f Makefile ]; then make; fi - mkdir -p work/$*/restart/RESTART + mkdir -p $(@D)/RESTART # Generate the half-period input namelist - # TODO: Assumes runtime set by DAYMAX, will fail if set by input.nml - cd work/$*/restart \ - && daymax=$$(grep DAYMAX MOM_input | cut -d '!' -f 1 | cut -d '=' -f 2 | xargs) \ - && timeunit=$$(grep TIMEUNIT MOM_input | cut -d '!' -f 1 | cut -d '=' -f 2 | xargs) \ - && if [ -z "$${timeunit}" ]; then timeunit="8.64e4"; fi \ - && printf -v timeunit_int "%.f" "$${timeunit}" \ - && halfperiod=$$(printf "%.f" $$(bc <<< "scale=10; 0.5 * $${daymax} * $${timeunit_int}")) \ - && printf "\n&ocean_solo_nml\n seconds = $${halfperiod}\n/\n" >> input.nml + # TODO: Assumes that runtime set by DAYMAX, will fail if set by input.nml + cd $(@D) \ + && daymax=$$(grep DAYMAX MOM_input | cut -d '!' -f 1 | cut -d '=' -f 2 | xargs) \ + && timeunit=$$(grep TIMEUNIT MOM_input | cut -d '!' -f 1 | cut -d '=' -f 2 | xargs) \ + && if [ -z "$${timeunit}" ]; then timeunit="8.64e4"; fi \ + && printf -v timeunit_int "%.f" "$${timeunit}" \ + && halfperiod=$$(printf "%.f" $$(bc <<< "scale=10; 0.5 * $${daymax} * $${timeunit_int}")) \ + && printf "\n&ocean_solo_nml\n seconds = $${halfperiod}\n/\n" >> input.nml # Run the first half-period - cd work/$*/restart && $(MPIRUN) -n 1 ../../../$< 2> debug1.out > std1.out \ - || ! sed 's/^/$*.restart1: /' std1.out debug1.out \ - && sed 's/^/$*.restart1: /' std1.out + cd $(@D) && $(MPIRUN) -n 1 ../../../$< 2> std1.err > std1.out \ + || !( \ + cat std1.out | tee ../../../results/$*/std.restart1.out | tail ; \ + cat std1.err | tee ../../../results/$*/std.restart1.err | tail ; \ + echo -e "${FAIL}: $*.restart failed at runtime." \ + ) # Setup the next inputs - cd work/$*/restart && rm -rf INPUT && mv RESTART INPUT - mkdir work/$*/restart/RESTART - cd work/$*/restart && sed -i -e "s/input_filename *= *'n'/input_filename = 'r'/g" input.nml + cd $(@D) && rm -rf INPUT && mv RESTART INPUT + mkdir $(@D)/RESTART + cd $(@D) && sed -i -e "s/input_filename *= *'n'/input_filename = 'r'/g" input.nml # Run the second half-period - cd work/$*/restart && $(MPIRUN) -n 1 ../../../$< 2> debug2.out > std2.out \ - || ! sed 's/^/$*.restart2: /' std2.out debug2.out \ - && sed 's/^/$*.restart2: /' std2.out - # Archive the results and cleanup - mkdir -p $(@D) - cp work/$*/restart/ocean.stats $@ + cd $(@D) && $(MPIRUN) -n 1 ../../../$< 2> std2.err > std2.out \ + || !( \ + cat std2.out | tee ../../../results/$*/std.restart2.out | tail ; \ + cat std2.err | tee ../../../results/$*/std.restart2.err | tail ; \ + echo -e "${FAIL}: $*.restart failed at runtime." \ + ) # TODO: Restart checksum diagnostics +#--- +# Not a true rule; only call this after `make test` to summarize test results. +.PHONY: test.summary +test.summary: + @if ls results/*/* &> /dev/null; then \ + if ls results/*/std.*.err &> /dev/null; then \ + echo "The following tests failed to complete:" ; \ + ls results/*/std.*.out \ + | awk '{split($$0,a,"/"); split(a[3],t,"."); print " ",a[2],":",t[2]}' ; \ + fi; \ + if ls results/*/ocean.stats.*.diff &> /dev/null; then \ + echo "The following tests report solution regressions:" ; \ + ls results/*/ocean.stats.*.diff \ + | awk '{split($$0,a,"/"); split(a[3],t,"."); print " ",a[2],":",t[3]}' ; \ + fi; \ + if ls results/*/chksum_diag.*.diff &> /dev/null; then \ + echo "The following tests report diagnostic regressions:" ; \ + ls results/*/chksum_diag.*.diff \ + | awk '{split($$0,a,"/"); split(a[3],t,"."); print " ",a[2],":",t[2]}' ; \ + fi; \ + false ; \ + else \ + echo -e "${PASS}: All tests passed!"; \ + fi + + #---- +# NOTE: These tests assert that we are in the .testing directory. + .PHONY: clean clean: clean.stats - @# Assert that we are in .testing for recursive delete @[ $$(basename $$(pwd)) = .testing ] rm -rf build .PHONY: clean.stats clean.stats: - @# Assert that we are in .testing for recursive delete @[ $$(basename $$(pwd)) = .testing ] rm -rf work results diff --git a/.travis.yml b/.travis.yml index ac7cab1b14..34bbe0dcce 100644 --- a/.travis.yml +++ b/.travis.yml @@ -40,7 +40,8 @@ jobs: - make all - echo -en 'travis_fold:end:script.1\\r' - echo 'Running tests...' && echo -en 'travis_fold:start:script.2\\r' - - make test + - make -k -s test + - make test.summary - echo -en 'travis_fold:end:script.2\\r' # NOTE: Code coverage upload is here to reduce load imbalance @@ -58,5 +59,5 @@ jobs: - make build.regressions - echo -en 'travis_fold:end:script.1\\r' - echo 'Running tests...' && echo -en 'travis_fold:start:script.2\\r' - - make test.regressions + - make -k -s test.regressions - echo -en 'travis_fold:end:script.2\\r' From 663799dd98de9c74f8055a706df908227790fa72 Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Thu, 14 May 2020 16:45:17 -0400 Subject: [PATCH 282/316] Travis: remove test folding Test logging is now much shorter, so folding is less important. --- .travis.yml | 5 +---- 1 file changed, 1 insertion(+), 4 deletions(-) diff --git a/.travis.yml b/.travis.yml index 34bbe0dcce..6b0b4c2a5e 100644 --- a/.travis.yml +++ b/.travis.yml @@ -39,10 +39,8 @@ jobs: - echo 'Build executables...' && echo -en 'travis_fold:start:script.1\\r' - make all - echo -en 'travis_fold:end:script.1\\r' - - echo 'Running tests...' && echo -en 'travis_fold:start:script.2\\r' - make -k -s test - make test.summary - - echo -en 'travis_fold:end:script.2\\r' # NOTE: Code coverage upload is here to reduce load imbalance - if: type = pull_request @@ -58,6 +56,5 @@ jobs: - echo 'Build executables...' && echo -en 'travis_fold:start:script.1\\r' - make build.regressions - echo -en 'travis_fold:end:script.1\\r' - - echo 'Running tests...' && echo -en 'travis_fold:start:script.2\\r' - make -k -s test.regressions - - echo -en 'travis_fold:end:script.2\\r' + - make test.summary From 3567d8397170cef7d005811a7a95a51efc6b0eda Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Thu, 14 May 2020 17:34:10 -0400 Subject: [PATCH 283/316] Makefile: codecov reporting CodeCov reporting log is now saved to results/ rather than piped to stdout, further reducing test logging output. --- .testing/Makefile | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/.testing/Makefile b/.testing/Makefile index f0ecb09a0a..bcfea91e40 100644 --- a/.testing/Makefile +++ b/.testing/Makefile @@ -304,7 +304,12 @@ work/%/$(1)/ocean.stats work/%/$(1)/chksum_diag: build/$(2)/MOM6 echo -e "${FAIL}: $$*.$(1) failed at runtime." \ ) @echo -e "${DONE}: $$*.$(1); no runtime errors." - if [ $(3) ]; then cd .. && bash <(curl -s https://codecov.io/bash) -n $$@; fi + if [ $(3) ]; then \ + mkdir -p results/$$* ; \ + bash <(curl -s https://codecov.io/bash) -n $$@ \ + > results/$$*/codecov.$(1).out \ + 2> results/$$*/codecov.$(1).err ; \ + fi endef From c233e02fe5f6720ddd29724f77e3be27561dd203 Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Thu, 14 May 2020 20:40:12 -0400 Subject: [PATCH 284/316] Makefile: copy codecov output to work, not results. We were saving codecov output to results, but this was breaking the `test.summary` test, which only returns true if `results` is empty. This change should resolve this issue. --- .testing/Makefile | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/.testing/Makefile b/.testing/Makefile index bcfea91e40..66a116a32a 100644 --- a/.testing/Makefile +++ b/.testing/Makefile @@ -307,8 +307,8 @@ work/%/$(1)/ocean.stats work/%/$(1)/chksum_diag: build/$(2)/MOM6 if [ $(3) ]; then \ mkdir -p results/$$* ; \ bash <(curl -s https://codecov.io/bash) -n $$@ \ - > results/$$*/codecov.$(1).out \ - 2> results/$$*/codecov.$(1).err ; \ + > work/$$*/codecov.$(1).out \ + 2> work/$$*/codecov.$(1).err ; \ fi endef From fab21a74923ed373d158fde0fe80e003cb071baa Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Tue, 19 May 2020 13:54:17 +0000 Subject: [PATCH 285/316] Fixes an integer-kind mismatch in MOM_random, seed_from_time() - gcc/8.3.0 issued `Error: Integer too big for its kind` reported in feedback on PR #1111. The intent was to assume kind=4 in these calculations but apparently our compilers were promoting `mod(dy + 32*(mo + 13*yr), 2147483648)` to kind=8. There were two mistakes in the expression: - the use of `2147483648` in the `mod` is not representable with kind=4; - the `mod` produces negative values and should have been a `modulo`. - This commit reduces the range of the results by one number on the positive side and removes all the negatives. --- src/framework/MOM_random.F90 | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/src/framework/MOM_random.F90 b/src/framework/MOM_random.F90 index c37893012e..14800df9aa 100644 --- a/src/framework/MOM_random.F90 +++ b/src/framework/MOM_random.F90 @@ -143,8 +143,9 @@ integer function seed_from_time(Time) call get_date(Time,yr,mo,dy,hr,mn,sc) s1 = sc + 61*(mn + 61*hr) + 379 ! Range 379 .. 89620 ! Fun fact: 2147483647 is the eighth Mersenne prime. - ! This is not the reason for using 2147483647+1 here. - s2 = mod(dy + 32*(mo + 13*yr), 2147483648) ! Range 0 .. 2147483647 + ! This is not the reason for using 2147483647 here. It is the + ! largest integer of kind=4. + s2 = modulo(dy + 32*(mo + 13*yr), 2147483647_4) ! Range 0 .. 2147483646 seed_from_time = ieor(s1*4111, s2) end function seed_from_time From 634991d9c21a7ce84cc563aa9d59b9c53f4224d5 Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Tue, 19 May 2020 11:05:29 -0400 Subject: [PATCH 286/316] Fixes an integer-kind mismatch in MOM_random, seed_from_time() (#1113) - gcc/8.3.0 issued `Error: Integer too big for its kind` reported in feedback on PR #1111. The intent was to assume kind=4 in these calculations but apparently our compilers were promoting `mod(dy + 32*(mo + 13*yr), 2147483648)` to kind=8. There were two mistakes in the expression: - the use of `2147483648` in the `mod` is not representable with kind=4; - the `mod` produces negative values and should have been a `modulo`. - This commit reduces the range of the results by one number on the positive side and removes all the negatives. --- src/framework/MOM_random.F90 | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/src/framework/MOM_random.F90 b/src/framework/MOM_random.F90 index c37893012e..14800df9aa 100644 --- a/src/framework/MOM_random.F90 +++ b/src/framework/MOM_random.F90 @@ -143,8 +143,9 @@ integer function seed_from_time(Time) call get_date(Time,yr,mo,dy,hr,mn,sc) s1 = sc + 61*(mn + 61*hr) + 379 ! Range 379 .. 89620 ! Fun fact: 2147483647 is the eighth Mersenne prime. - ! This is not the reason for using 2147483647+1 here. - s2 = mod(dy + 32*(mo + 13*yr), 2147483648) ! Range 0 .. 2147483647 + ! This is not the reason for using 2147483647 here. It is the + ! largest integer of kind=4. + s2 = modulo(dy + 32*(mo + 13*yr), 2147483647_4) ! Range 0 .. 2147483646 seed_from_time = ieor(s1*4111, s2) end function seed_from_time From 2f44ca7ce12410272a185556348547000d095790 Mon Sep 17 00:00:00 2001 From: Alper Altuntas Date: Tue, 19 May 2020 13:03:35 -0600 Subject: [PATCH 287/316] correct conflict resolve in KPP --- src/parameterizations/vertical/MOM_CVMix_KPP.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/parameterizations/vertical/MOM_CVMix_KPP.F90 b/src/parameterizations/vertical/MOM_CVMix_KPP.F90 index 2a160a3021..a6b370f17e 100644 --- a/src/parameterizations/vertical/MOM_CVMix_KPP.F90 +++ b/src/parameterizations/vertical/MOM_CVMix_KPP.F90 @@ -992,7 +992,7 @@ subroutine KPP_compute_BLD(CS, G, GV, US, h, Temp, Salt, u, v, tv, uStar, buoyFl !$OMP deltarho, N2_1d, ws_1d, LangEnhVT2, enhvt2, wst, & !$OMP BulkRi_1d, zBottomMinusOffset) & !$OMP shared(G, GV, CS, US, uStar, h, buoy_scale, buoyFlux, & - !$OMP Temp, Salt, waves, EOS, GoRho, u, v) + !$OMP Temp, Salt, waves, tv, EOS, GoRho, u, v) do j = G%jsc, G%jec do i = G%isc, G%iec From b34478800b61164622271590882f4218b1a15ee6 Mon Sep 17 00:00:00 2001 From: Alper Altuntas Date: Tue, 19 May 2020 13:05:57 -0600 Subject: [PATCH 288/316] undo indent change from conflict resolve --- src/equation_of_state/MOM_EOS.F90 | 18 +++++++++--------- 1 file changed, 9 insertions(+), 9 deletions(-) diff --git a/src/equation_of_state/MOM_EOS.F90 b/src/equation_of_state/MOM_EOS.F90 index 25bd7580d9..6de99c5bef 100644 --- a/src/equation_of_state/MOM_EOS.F90 +++ b/src/equation_of_state/MOM_EOS.F90 @@ -1757,15 +1757,15 @@ subroutine int_density_dz_generic_plm (T_t, T_b, S_t, S_b, z_t, z_b, rho_ref, & do I=Isq,Ieq 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))) - 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)) + & - 12.0*intz(3)) + ! 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))) + 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)) + & + 12.0*intz(3)) enddo enddo endif From 532e65ad51a05dfe29cbc79e719cda765e5b25f8 Mon Sep 17 00:00:00 2001 From: Alper Altuntas Date: Tue, 19 May 2020 14:39:38 -0600 Subject: [PATCH 289/316] undo OMP changes in MOM_EOS --- src/equation_of_state/MOM_EOS.F90 | 33 ++++++++++++++----------------- 1 file changed, 15 insertions(+), 18 deletions(-) diff --git a/src/equation_of_state/MOM_EOS.F90 b/src/equation_of_state/MOM_EOS.F90 index 6de99c5bef..c584b68c89 100644 --- a/src/equation_of_state/MOM_EOS.F90 +++ b/src/equation_of_state/MOM_EOS.F90 @@ -1649,12 +1649,6 @@ subroutine int_density_dz_generic_plm (T_t, T_b, S_t, S_b, z_t, z_b, rho_ref, & ! ============================= ! 1. Compute vertical integrals ! ============================= - - !$OMP parallel default(shared) private(jin,iin,dz,p5,S5,T5,r5,rho_anom,hWght,hL,hR,iDenom,Ttl,Ttr, & - !$OMP Tbl,Tbr,Stl,Str,Sbl,Sbr,w_left,w_right,dz_x,dz_y,pos,T15,S15, & - !$OMP p15,r15,weight_t,weight_b,intz) - - !$OMP do do j=Jsq,Jeq+1 do i = Isq,Ieq+1 dz(i) = z_t(i,j) - z_b(i,j) @@ -1747,6 +1741,7 @@ subroutine int_density_dz_generic_plm (T_t, T_b, S_t, S_b, z_t, z_b, rho_ref, & T15(pos+n) = weight_t * T15(pos+1) + weight_b * T15(pos+5) enddo enddo + enddo if (rho_scale /= 1.0) then call calculate_density(T15, S15, p15, r15, 1, 15*(ieq-isq+1), EOS, rho_ref=rho_ref_mks, scale=rho_scale) @@ -1757,18 +1752,17 @@ subroutine int_density_dz_generic_plm (T_t, T_b, S_t, S_b, z_t, z_b, rho_ref, & do I=Isq,Ieq 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))) - 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)) + & - 12.0*intz(3)) + ! 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))) 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)) + & + 12.0*intz(3)) enddo - endif + enddo ; endif ! ================================================== ! 3. Compute horizontal integrals in the y direction @@ -1830,6 +1824,7 @@ subroutine int_density_dz_generic_plm (T_t, T_b, S_t, S_b, z_t, z_b, rho_ref, & T15(pos+n) = weight_t * T15(pos+1) + weight_b * T15(pos+5) enddo enddo + enddo if (rho_scale /= 1.0) then call calculate_density_array(T15(15*HI%isc+1:), S15(15*HI%isc+1:), p15(15*HI%isc+1:), & @@ -1849,9 +1844,11 @@ subroutine int_density_dz_generic_plm (T_t, T_b, S_t, S_b, z_t, z_b, rho_ref, & 32.0*(r15(pos+2)+r15(pos+4)) + & 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)) + & + 12.0*intz(3)) enddo - endif - !$OMP end parallel + enddo ; endif end subroutine int_density_dz_generic_plm ! ========================================================================== From 97547426a9942e4c1acb3a68e38b61d70fb77b61 Mon Sep 17 00:00:00 2001 From: Alper Altuntas Date: Tue, 19 May 2020 16:24:15 -0600 Subject: [PATCH 290/316] Fix OMP directives broken by merge --- src/parameterizations/vertical/MOM_CVMix_KPP.F90 | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/parameterizations/vertical/MOM_CVMix_KPP.F90 b/src/parameterizations/vertical/MOM_CVMix_KPP.F90 index a6b370f17e..01a39d394b 100644 --- a/src/parameterizations/vertical/MOM_CVMix_KPP.F90 +++ b/src/parameterizations/vertical/MOM_CVMix_KPP.F90 @@ -992,7 +992,7 @@ subroutine KPP_compute_BLD(CS, G, GV, US, h, Temp, Salt, u, v, tv, uStar, buoyFl !$OMP deltarho, N2_1d, ws_1d, LangEnhVT2, enhvt2, wst, & !$OMP BulkRi_1d, zBottomMinusOffset) & !$OMP shared(G, GV, CS, US, uStar, h, buoy_scale, buoyFlux, & - !$OMP Temp, Salt, waves, tv, EOS, GoRho, u, v) + !$OMP Temp, Salt, waves, tv, GoRho, u, v) do j = G%jsc, G%jec do i = G%isc, G%iec @@ -1317,7 +1317,7 @@ subroutine KPP_smooth_BLD(CS,G,GV,h) ! apply smoothing on OBL depth !$OMP parallel do default(none) shared(G, GV, CS, h, OBLdepth_prev) & - !$OMP private(wc, ww, we, wn, ws, dh, hcorr, pref, cellHeight, iFaceHeight) + !$OMP private(wc, ww, we, wn, ws, dh, hcorr, cellHeight, iFaceHeight) do j = G%jsc, G%jec do i = G%isc, G%iec @@ -1382,7 +1382,7 @@ subroutine KPP_get_BLD(CS, BLD, G, US, m_to_BLD_units) scale = US%m_to_Z ; if (present(m_to_BLD_units)) scale = m_to_BLD_units - !$OMP parallel do default(none) shared(BLD, CS, G) + !$OMP parallel do default(none) shared(BLD, CS, G, scale) do j = G%jsc, G%jec ; do i = G%isc, G%iec BLD(i,j) = scale * CS%OBLdepth(i,j) enddo ; enddo From 4041cc90b81ff51dc8ae1e981bb847bbdaa15f49 Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Mon, 25 May 2020 12:12:52 -0600 Subject: [PATCH 291/316] Fix bug when applying ND only in the interior When using the option to apply neutral diffusion only below the surface boundary layer we were using (1.-zeta). This is wrong. It should be just (zeta). --- src/tracer/MOM_neutral_diffusion.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/tracer/MOM_neutral_diffusion.F90 b/src/tracer/MOM_neutral_diffusion.F90 index 30cdec3b37..890bae928c 100644 --- a/src/tracer/MOM_neutral_diffusion.F90 +++ b/src/tracer/MOM_neutral_diffusion.F90 @@ -461,7 +461,7 @@ subroutine neutral_diffusion_calc_coeffs(G, GV, US, h, T, S, CS, p_surf) CS%Pint(i,j,:), CS%Tint(i,j,:), CS%Sint(i,j,:), CS%dRdT(i,j,:), CS%dRdS(i,j,:), & CS%Pint(i+1,j,:), CS%Tint(i+1,j,:), CS%Sint(i+1,j,:), CS%dRdT(i+1,j,:), CS%dRdS(i+1,j,:), & CS%uPoL(I,j,:), CS%uPoR(I,j,:), CS%uKoL(I,j,:), CS%uKoR(I,j,:), CS%uhEff(I,j,:), & - k_bot(I,j), k_bot(I+1,j), 1.-zeta_bot(I,j), 1.-zeta_bot(I+1,j)) + k_bot(I,j), k_bot(I+1,j), zeta_bot(I,j), zeta_bot(I+1,j)) else call find_neutral_surface_positions_discontinuous(CS, G%ke, & CS%P_i(i,j,:,:), h(i,j,:), CS%T_i(i,j,:,:), CS%S_i(i,j,:,:), CS%ppoly_coeffs_T(i,j,:,:), & @@ -482,7 +482,7 @@ subroutine neutral_diffusion_calc_coeffs(G, GV, US, h, T, S, CS, p_surf) CS%Pint(i,j,:), CS%Tint(i,j,:), CS%Sint(i,j,:), CS%dRdT(i,j,:), CS%dRdS(i,j,:), & CS%Pint(i,j+1,:), CS%Tint(i,j+1,:), CS%Sint(i,j+1,:), CS%dRdT(i,j+1,:), CS%dRdS(i,j+1,:), & CS%vPoL(i,J,:), CS%vPoR(i,J,:), CS%vKoL(i,J,:), CS%vKoR(i,J,:), CS%vhEff(i,J,:), & - k_bot(i,J), k_bot(i,J+1), 1.-zeta_bot(i,J), 1.-zeta_bot(i,J+1)) + k_bot(i,J), k_bot(i,J+1), zeta_bot(i,J), zeta_bot(i,J+1)) else call find_neutral_surface_positions_discontinuous(CS, G%ke, & CS%P_i(i,j,:,:), h(i,j,:), CS%T_i(i,j,:,:), CS%S_i(i,j,:,:), CS%ppoly_coeffs_T(i,j,:,:), & From a69aea96164c73db20b3e1b204b7ff89e704799c Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Thu, 28 May 2020 16:23:40 -0600 Subject: [PATCH 292/316] Add new diagnostics Moved calculation of vorticity and divergence outside the Leith loop. Added diagnostics for shearing strain and horizontal tension. --- .../lateral/MOM_hor_visc.F90 | 56 +++++++++++-------- 1 file changed, 33 insertions(+), 23 deletions(-) diff --git a/src/parameterizations/lateral/MOM_hor_visc.F90 b/src/parameterizations/lateral/MOM_hor_visc.F90 index 0a126f10d8..a60d60bb9d 100644 --- a/src/parameterizations/lateral/MOM_hor_visc.F90 +++ b/src/parameterizations/lateral/MOM_hor_visc.F90 @@ -179,6 +179,7 @@ module MOM_hor_visc integer :: id_Kh_h = -1, id_Kh_q = -1 integer :: id_GME_coeff_h = -1, id_GME_coeff_q = -1 integer :: id_vort_xy_q = -1, id_div_xx_h = -1 + integer :: id_sh_xy_q = -1, id_sh_xx_h = -1 integer :: id_FrictWork = -1, id_FrictWorkIntz = -1 integer :: id_FrictWork_GME = -1 !>@} @@ -288,6 +289,7 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, Ah_q, & ! biharmonic viscosity at corner points [L4 T-1 ~> m4 s-1] Kh_q, & ! Laplacian viscosity at corner points [L2 T-1 ~> m2 s-1] vort_xy_q, & ! vertical vorticity at corner points [T-1 ~> s-1] + sh_xy_q, & ! horizontal shearing strain at corner points [T-1 ~> s-1] GME_coeff_q, & !< GME coeff. at q-points [L2 T-1 ~> m2 s-1] max_diss_rate_q ! maximum possible energy dissipated by lateral friction [L2 T-3 ~> m2 s-3] @@ -301,7 +303,8 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, max_diss_rate_h, & ! maximum possible energy dissipated by lateral friction [L2 T-3 ~> m2 s-3] FrictWork, & ! work done by MKE dissipation mechanisms [R L2 T-3 ~> W m-2] FrictWork_GME, & ! work done by GME [R L2 T-3 ~> W m-2] - div_xx_h ! horizontal divergence [T-1 ~> s-1] + div_xx_h, & ! horizontal divergence [T-1 ~> s-1] + sh_xx_h ! horizontal tension (du/dx - dv/dy) including metric terms [T-1 ~> s-1] real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: & grid_Re_Kh, & !< Grid Reynolds number for Laplacian horizontal viscosity at h points [nondim] grid_Re_Ah, & !< Grid Reynolds number for Biharmonic horizontal viscosity at h points [nondim] @@ -478,7 +481,7 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, !$OMP h_neglect, h_neglect3, FWfrac, inv_PI3, inv_PI6, H0_GME, & !$OMP diffu, diffv, max_diss_rate_h, max_diss_rate_q, & !$OMP Kh_h, Kh_q, Ah_h, Ah_q, FrictWork, FrictWork_GME, & - !$OMP div_xx_h, vort_xy_q, GME_coeff_h, GME_coeff_q, & + !$OMP div_xx_h, sh_xx_h, vort_xy_q, sh_xy_q, GME_coeff_h, GME_coeff_q, & !$OMP TD, KH_u_GME, KH_v_GME, grid_Re_Kh, grid_Re_Ah & !$OMP ) & !$OMP private( & @@ -689,18 +692,23 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, endif; endif endif - if ((CS%Leith_Kh) .or. (CS%Leith_Ah)) then + ! Vorticity + if (CS%no_slip) then + do J=js-2,Jeq+2 ; do I=is-2,Ieq+2 + vort_xy(I,J) = (2.0-G%mask2dBu(I,J)) * ( dvdx(I,J) - dudy(I,J) ) + enddo ; enddo + else + do J=js-2,Jeq+2 ; do I=is-2,Ieq+2 + vort_xy(I,J) = G%mask2dBu(I,J) * ( dvdx(I,J) - dudy(I,J) ) + enddo ; enddo + endif - ! Vorticity - if (CS%no_slip) then - do J=js-2,Jeq+2 ; do I=is-2,Ieq+2 - vort_xy(I,J) = (2.0-G%mask2dBu(I,J)) * ( dvdx(I,J) - dudy(I,J) ) - enddo ; enddo - else - do J=js-2,Jeq+2 ; do I=is-2,Ieq+2 - vort_xy(I,J) = G%mask2dBu(I,J) * ( dvdx(I,J) - dudy(I,J) ) - enddo ; enddo - endif + ! Divergence + do j=Jsq-1,Jeq+2 ; do i=Isq-1,Ieq+2 + div_xx(i,j) = dudx(i,j) + dvdy(i,j) + enddo ; enddo + + if ((CS%Leith_Kh) .or. (CS%Leith_Ah)) then ! Vorticity gradient do J=js-2,Jeq+2 ; do i=is-1,Ieq+2 @@ -725,10 +733,6 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, enddo ; enddo if (CS%modified_Leith) then - ! Divergence - do j=Jsq-1,Jeq+2 ; do i=Isq-1,Ieq+2 - div_xx(i,j) = dudx(i,j) + dvdy(i,j) - enddo ; enddo ! Divergence gradient do j=Jsq-1,Jeq+2 ; do I=Isq-1,Ieq+1 @@ -865,6 +869,7 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, endif if (CS%id_div_xx_h>0) div_xx_h(i,j,k) = div_xx(i,j) + if (CS%id_sh_xx_h>0) sh_xx_h(i,j,k) = sh_xx(i,j) str_xx(i,j) = -Kh * sh_xx(i,j) else ! not Laplacian @@ -1045,6 +1050,7 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, if (CS%id_Kh_q>0 .or. CS%debug) Kh_q(I,J,k) = Kh if (CS%id_vort_xy_q>0) vort_xy_q(I,J,k) = vort_xy(I,J) + if (CS%id_sh_xy_q>0) sh_xy_q(I,J,k) = sh_xy(I,J) str_xy(I,J) = -Kh * sh_xy(I,J) else ! not Laplacian @@ -1325,6 +1331,8 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, if (CS%id_grid_Re_Ah>0) call post_data(CS%id_grid_Re_Ah, grid_Re_Ah, CS%diag) if (CS%id_div_xx_h>0) call post_data(CS%id_div_xx_h, div_xx_h, CS%diag) if (CS%id_vort_xy_q>0) call post_data(CS%id_vort_xy_q, vort_xy_q, CS%diag) + if (CS%id_sh_xx_h>0) call post_data(CS%id_sh_xx_h, sh_xx_h, CS%diag) + if (CS%id_sh_xy_q>0) call post_data(CS%id_sh_xy_q, sh_xy_q, CS%diag) if (CS%id_Ah_q>0) call post_data(CS%id_Ah_q, Ah_q, CS%diag) if (CS%id_Kh_h>0) call post_data(CS%id_Kh_h, Kh_h, CS%diag) if (CS%id_grid_Re_Kh>0) call post_data(CS%id_grid_Re_Kh, grid_Re_Kh, CS%diag) @@ -2037,12 +2045,14 @@ subroutine hor_visc_init(Time, G, US, param_file, diag, CS, MEKE) 'Laplacian Horizontal Viscosity at q Points', 'm2 s-1', conversion=US%L_to_m**2*US%s_to_T) CS%id_grid_Re_Kh = register_diag_field('ocean_model', 'grid_Re_Kh', diag%axesTL, Time, & 'Grid Reynolds number for the Laplacian horizontal viscosity at h points', 'nondim') - if (CS%Leith_Kh) then - CS%id_vort_xy_q = register_diag_field('ocean_model', 'vort_xy_q', diag%axesBL, Time, & - 'Vertical vorticity at q Points', 's-1', conversion=US%s_to_T) - CS%id_div_xx_h = register_diag_field('ocean_model', 'div_xx_h', diag%axesTL, Time, & - 'Horizontal divergence at h Points', 's-1', conversion=US%s_to_T) - endif + CS%id_vort_xy_q = register_diag_field('ocean_model', 'vort_xy_q', diag%axesBL, Time, & + 'Vertical vorticity at q Points', 's-1', conversion=US%s_to_T) + CS%id_div_xx_h = register_diag_field('ocean_model', 'div_xx_h', diag%axesTL, Time, & + 'Horizontal divergence at h Points', 's-1', conversion=US%s_to_T) + CS%id_sh_xy_q = register_diag_field('ocean_model', 'sh_xy_q', diag%axesBL, Time, & + 'Shearing strain at q Points', 's-1', conversion=US%s_to_T) + CS%id_sh_xx_h = register_diag_field('ocean_model', 'sh_xx_h', diag%axesTL, Time, & + 'Horizontal tension at h Points', 's-1', conversion=US%s_to_T) endif if (CS%use_GME) then CS%id_GME_coeff_h = register_diag_field('ocean_model', 'GME_coeff_h', diag%axesTL, Time, & From 473c3f47b70998e5a7a84e7e0ca0d08588049938 Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Tue, 9 Jun 2020 13:24:38 -0600 Subject: [PATCH 293/316] Remove unused module --- config_src/nuopc_driver/mom_cap.F90 | 1 - 1 file changed, 1 deletion(-) diff --git a/config_src/nuopc_driver/mom_cap.F90 b/config_src/nuopc_driver/mom_cap.F90 index 219245e473..6b8d11141b 100644 --- a/config_src/nuopc_driver/mom_cap.F90 +++ b/config_src/nuopc_driver/mom_cap.F90 @@ -15,7 +15,6 @@ module MOM_cap_mod use mpp_mod, only: stdlog, stdout, mpp_root_pe, mpp_clock_id use mpp_mod, only: mpp_clock_begin, mpp_clock_end, MPP_CLOCK_SYNC use mpp_mod, only: MPP_CLOCK_DETAILED, CLOCK_COMPONENT, MAXPES -use time_interp_external_mod, only: time_interp_external_init use time_manager_mod, only: set_calendar_type, time_type, increment_date use time_manager_mod, only: set_time, set_date, get_time, get_date, month_name use time_manager_mod, only: GREGORIAN, JULIAN, NOLEAP, THIRTY_DAY_MONTHS, NO_CALENDAR From abb10ed4cd3054dd2a0ba2d5c099ea0bd0620cc2 Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Tue, 9 Jun 2020 14:00:20 -0600 Subject: [PATCH 294/316] Add calls to time_interp_external_init --- config_src/mct_driver/mom_ocean_model_mct.F90 | 103 +++++++++--------- .../nuopc_driver/mom_ocean_model_nuopc.F90 | 3 + 2 files changed, 56 insertions(+), 50 deletions(-) diff --git a/config_src/mct_driver/mom_ocean_model_mct.F90 b/config_src/mct_driver/mom_ocean_model_mct.F90 index f8a4a19532..2f94c9b7f9 100644 --- a/config_src/mct_driver/mom_ocean_model_mct.F90 +++ b/config_src/mct_driver/mom_ocean_model_mct.F90 @@ -11,56 +11,57 @@ module MOM_ocean_model_mct ! 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 -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_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_mct, only : surface_forcing_init, convert_IOB_to_fluxes -use MOM_surface_forcing_mct, only : convert_IOB_to_forces, ice_ocn_bnd_type_chksum -use MOM_surface_forcing_mct, only : ice_ocean_boundary_type, surface_forcing_CS -use MOM_surface_forcing_mct, 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_unit_scaling, only : unit_scale_type -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 +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 +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_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_mct, only : surface_forcing_init, convert_IOB_to_fluxes +use MOM_surface_forcing_mct, only : convert_IOB_to_forces, ice_ocn_bnd_type_chksum +use MOM_surface_forcing_mct, only : ice_ocean_boundary_type, surface_forcing_CS +use MOM_surface_forcing_mct, 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_unit_scaling, only : unit_scale_type +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 +use time_interp_external_mod, only : time_interp_external_init ! MCT specfic routines use MOM_domains, only : MOM_infra_end @@ -265,6 +266,8 @@ subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, gas_fields_ocn, i OS%is_ocean_pe = Ocean_sfc%is_ocean_pe if (.not.OS%is_ocean_pe) return + call time_interp_external_init + 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, & diff --git a/config_src/nuopc_driver/mom_ocean_model_nuopc.F90 b/config_src/nuopc_driver/mom_ocean_model_nuopc.F90 index 9946aec4f9..aabf456ca8 100644 --- a/config_src/nuopc_driver/mom_ocean_model_nuopc.F90 +++ b/config_src/nuopc_driver/mom_ocean_model_nuopc.F90 @@ -39,6 +39,7 @@ module MOM_ocean_model_nuopc 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 time_interp_external_mod,only : time_interp_external_init 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_unit_scaling, only : unit_scale_type @@ -267,6 +268,8 @@ subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, gas_fields_ocn, i OS%is_ocean_pe = Ocean_sfc%is_ocean_pe if (.not.OS%is_ocean_pe) return + call time_interp_external_init + 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, & From 7f478aa3e3734de8d0b88ad143e41f468e373d18 Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Mon, 25 May 2020 12:13:34 -0600 Subject: [PATCH 295/316] Add option to apply linear decay at the base of hbl This patch adds the option to apply a linear decay of the fluxes at the base of hbl. This had been already implemented but since it breaks the unit tests, which were designed to work without this option, adding this option will avoid breaking the tests. Also adding minor improvements in the bulk method. --- src/tracer/MOM_lateral_boundary_diffusion.F90 | 271 +++++++++++------- 1 file changed, 175 insertions(+), 96 deletions(-) diff --git a/src/tracer/MOM_lateral_boundary_diffusion.F90 b/src/tracer/MOM_lateral_boundary_diffusion.F90 index f244931376..a4b4bcb567 100644 --- a/src/tracer/MOM_lateral_boundary_diffusion.F90 +++ b/src/tracer/MOM_lateral_boundary_diffusion.F90 @@ -23,8 +23,7 @@ module MOM_lateral_boundary_diffusion use MOM_CVMix_KPP, only : KPP_get_BLD, KPP_CS use MOM_energetic_PBL, only : energetic_PBL_get_MLD, energetic_PBL_CS use MOM_diabatic_driver, only : diabatic_CS, extract_diabatic_member - -use iso_fortran_env, only : stdout=>output_unit, stderr=>error_unit +use iso_fortran_env, only : stdout=>output_unit, stderr=>error_unit implicit none ; private @@ -38,15 +37,18 @@ module MOM_lateral_boundary_diffusion !> Sets parameters for lateral boundary mixing module. type, public :: lateral_boundary_diffusion_CS ; private - integer :: method !< Determine which of the three methods calculate - !! and apply near boundary layer fluxes - !! 1. Bulk-layer approach - !! 2. Along layer - integer :: deg !< Degree of polynomial reconstruction - integer :: surface_boundary_scheme !< Which boundary layer scheme to use - !! 1. ePBL; 2. KPP - logical :: limiter !< Controls wether a flux limiter is applied. - !! Only valid when method = 1. + integer :: method !< Determine which of the three methods calculate + !! and apply near boundary layer fluxes + !! 1. Bulk-layer approach + !! 2. Along layer + integer :: deg !< Degree of polynomial reconstruction + integer :: surface_boundary_scheme !< Which boundary layer scheme to use + !! 1. ePBL; 2. KPP + logical :: limiter !< Controls wether a flux limiter is applied. + !! Only valid when method = 1. + logical :: linear !< If True, apply a linear transition at the base/top of the boundary. + !! The flux will be fully applied at k=k_min and zero at k=k_max. + type(remapping_CS) :: remap_CS !< Control structure to hold remapping configuration type(KPP_CS), pointer :: KPP_CSp => NULL() !< KPP control structure needed to get BLD type(energetic_PBL_CS), pointer :: energetic_PBL_CSp => NULL() !< ePBL control structure needed to get BLD @@ -110,6 +112,9 @@ logical function lateral_boundary_diffusion_init(Time, G, param_file, diag, diab "If True, apply a flux limiter in the LBD. This is only available \n"//& "when LATERAL_BOUNDARY_METHOD=1.", default=.false.) endif + call get_param(param_file, mdl, "LBD_LINEAR_TRANSITION", CS%linear, & + "If True, apply a linear transition at the base/top of the boundary. \n"//& + "The flux will be fully applied at k=k_min and zero at k=k_max.", default=.false.) call get_param(param_file, mdl, "LBD_BOUNDARY_EXTRAP", boundary_extrap, & "Use boundary extrapolation in LBD code", & default=.false.) @@ -179,6 +184,7 @@ subroutine lateral_boundary_diffusion(G, GV, US, h, Coef_x, Coef_y, dt, Reg, CS) call build_reconstructions_1d( CS%remap_CS, G%ke, h(i,j,:), tracer%t(i,j,:), ppoly0_coefs(i,j,:,:), & ppoly0_E(i,j,:,:), ppoly_S, remap_method, GV%H_subroundoff, GV%H_subroundoff) enddo ; enddo + ! Diffusive fluxes in the i-direction uFlx(:,:,:) = 0. vFlx(:,:,:) = 0. @@ -193,7 +199,8 @@ subroutine lateral_boundary_diffusion(G, GV, US, h, Coef_x, Coef_y, dt, Reg, CS) call fluxes_bulk_method(SURFACE, GV%ke, CS%deg, h(I,j,:), h(I+1,j,:), hbl(I,j), hbl(I+1,j), & G%areaT(I,j), G%areaT(I+1,j), tracer%t(I,j,:), tracer%t(I+1,j,:), & ppoly0_coefs(I,j,:,:), ppoly0_coefs(I+1,j,:,:), ppoly0_E(I,j,:,:), & - ppoly0_E(I+1,j,:,:), remap_method, Coef_x(I,j), uFlx_bulk(I,j), uFlx(I,j,:), CS%limiter) + ppoly0_E(I+1,j,:,:), remap_method, Coef_x(I,j), uFlx_bulk(I,j), uFlx(I,j,:), CS%limiter, & + CS%linear) endif enddo enddo @@ -203,7 +210,8 @@ subroutine lateral_boundary_diffusion(G, GV, US, h, Coef_x, Coef_y, dt, Reg, CS) call fluxes_bulk_method(SURFACE, GV%ke, CS%deg, h(i,J,:), h(i,J+1,:), hbl(i,J), hbl(i,J+1), & G%areaT(i,J), G%areaT(i,J+1), tracer%t(i,J,:), tracer%t(i,J+1,:), & ppoly0_coefs(i,J,:,:), ppoly0_coefs(i,J+1,:,:), ppoly0_E(i,J,:,:), & - ppoly0_E(i,J+1,:,:), remap_method, Coef_y(i,J), vFlx_bulk(i,J), vFlx(i,J,:), CS%limiter) + ppoly0_E(i,J+1,:,:), remap_method, Coef_y(i,J), vFlx_bulk(i,J), vFlx(i,J,:), CS%limiter, & + CS%linear) endif enddo enddo @@ -216,18 +224,20 @@ subroutine lateral_boundary_diffusion(G, GV, US, h, Coef_x, Coef_y, dt, Reg, CS) do j=G%jsc,G%jec do i=G%isc-1,G%iec if (G%mask2dCu(I,j)>0.) then - call fluxes_layer_method(SURFACE, GV%ke, CS%deg, h(I,j,:), h(I+1,j,:), hbl(I,j), hbl(I+1,j), & - G%areaT(I,j), G%areaT(I+1,j), tracer%t(I,j,:), tracer%t(I+1,j,:), ppoly0_coefs(I,j,:,:), & - ppoly0_coefs(I+1,j,:,:), ppoly0_E(I,j,:,:), ppoly0_E(I+1,j,:,:), remap_method, Coef_x(I,j), uFlx(I,j,:)) + call fluxes_layer_method(SURFACE, GV%ke, CS%deg, h(I,j,:), h(I+1,j,:), hbl(I,j), hbl(I+1,j), & + G%areaT(I,j), G%areaT(I+1,j), tracer%t(I,j,:), tracer%t(I+1,j,:), ppoly0_coefs(I,j,:,:), & + ppoly0_coefs(I+1,j,:,:), ppoly0_E(I,j,:,:), ppoly0_E(I+1,j,:,:), remap_method, Coef_x(I,j), & + uFlx(I,j,:), CS%linear) endif enddo enddo do J=G%jsc-1,G%jec do i=G%isc,G%iec if (G%mask2dCv(i,J)>0.) then - call fluxes_layer_method(SURFACE, GV%ke, CS%deg, h(i,J,:), h(i,J+1,:), hbl(i,J), hbl(i,J+1), & - G%areaT(i,J), G%areaT(i,J+1), tracer%t(i,J,:), tracer%t(i,J+1,:), ppoly0_coefs(i,J,:,:), & - ppoly0_coefs(i,J+1,:,:), ppoly0_E(i,J,:,:), ppoly0_E(i,J+1,:,:), remap_method, Coef_y(i,J), vFlx(i,J,:)) + call fluxes_layer_method(SURFACE, GV%ke, CS%deg, h(i,J,:), h(i,J+1,:), hbl(i,J), hbl(i,J+1), & + G%areaT(i,J), G%areaT(i,J+1), tracer%t(i,J,:), tracer%t(i,J+1,:), ppoly0_coefs(i,J,:,:), & + ppoly0_coefs(i,J+1,:,:), ppoly0_E(i,J,:,:), ppoly0_E(i,J+1,:,:), remap_method, Coef_y(i,J), & + vFlx(i,J,:), CS%linear) endif enddo enddo @@ -298,26 +308,26 @@ end subroutine lateral_boundary_diffusion !< Calculate bulk layer value of a scalar quantity as the thickness weighted average real function bulk_average(boundary, nk, deg, h, hBLT, phi, ppoly0_E, ppoly0_coefs, method, k_top, zeta_top, k_bot, & zeta_bot) - integer :: boundary !< SURFACE or BOTTOM [nondim] - integer :: nk !< Number of layers [nondim] - integer :: deg !< Degree of polynomial [nondim] - real, dimension(nk) :: h !< Layer thicknesses [H ~> m or kg m-2] - real :: hBLT !< Depth of the boundary layer [H ~> m or kg m-2] + integer :: boundary !< SURFACE or BOTTOM [nondim] + integer :: nk !< Number of layers [nondim] + integer :: deg !< Degree of polynomial [nondim] + real, dimension(nk) :: h !< Layer thicknesses [H ~> m or kg m-2] + real :: hBLT !< Depth of the boundary layer [H ~> m or kg m-2] real, dimension(nk) :: phi !< Scalar quantity - real, dimension(nk,2) :: ppoly0_E !< Edge value of polynomial - real, dimension(nk,deg+1) :: ppoly0_coefs !< Coefficients of polynomial - integer :: method !< Remapping scheme to use + real, dimension(nk,2) :: ppoly0_E(:,:) !< Edge value of polynomial + real, dimension(nk,deg+1) :: ppoly0_coefs(:,:) !< Coefficients of polynomial + integer :: method !< Remapping scheme to use integer :: k_top !< Index of the first layer within the boundary real :: zeta_top !< Fraction of the layer encompassed by the bottom boundary layer !! (0 if none, 1. if all). For the surface, this is always 0. because - !! integration starts at the surface [nondim] + !! integration starts at the surface [nondim] integer :: k_bot !< Index of the last layer within the boundary real :: zeta_bot !< Fraction of the layer encompassed by the surface boundary layer !! (0 if none, 1. if all). For the bottom boundary layer, this is always 1. - !! because integration starts at the bottom [nondim] + !! because integration starts at the bottom [nondim] ! Local variables - real :: htot !< Running sum of the thicknesses (top to bottom) [H ~> m or kg m-2] + real :: htot !< Running sum of the thicknesses (top to bottom) integer :: k !< k indice @@ -428,43 +438,48 @@ end subroutine boundary_k_range !> Calculate the lateral boundary diffusive fluxes using the layer by layer method. !! See \ref section_method2 subroutine fluxes_layer_method(boundary, nk, deg, h_L, h_R, hbl_L, hbl_R, area_L, area_R, phi_L, phi_R, & - ppoly0_coefs_L, ppoly0_coefs_R, ppoly0_E_L, ppoly0_E_R, method, khtr_u, F_layer) + ppoly0_coefs_L, ppoly0_coefs_R, ppoly0_E_L, ppoly0_E_R, method, khtr_u, & + F_layer, linear_decay) integer, intent(in ) :: boundary !< Which boundary layer SURFACE or BOTTOM [nondim] integer, intent(in ) :: nk !< Number of layers [nondim] integer, intent(in ) :: deg !< order of the polynomial reconstruction [nondim] - real, dimension(nk), intent(in ) :: h_L !< Layer thickness (left) [H ~> m or kg m-2] - real, dimension(nk), intent(in ) :: h_R !< Layer thickness (right) [H ~> m or kg m-2] + real, dimension(nk), intent(in ) :: h_L !< Layer thickness (left) [H ~> m or kg m-2] + real, dimension(nk), intent(in ) :: h_R !< Layer thickness (right) [H ~> m or kg m-2] real, intent(in ) :: hbl_L !< Thickness of the boundary boundary - !! layer (left) [H ~> m or kg m-2] + !! layer (left) [H ~> m or kg m-2] real, intent(in ) :: hbl_R !< Thickness of the boundary boundary - !! layer (right) [H ~> m or kg m-2] - real, intent(in ) :: area_L !< Area of the horizontal grid (left) [L2 ~> m2] - real, intent(in ) :: area_R !< Area of the horizontal grid (right) [L2 ~> m2] - real, dimension(nk), intent(in ) :: phi_L !< Tracer values (left) [conc] - real, dimension(nk), intent(in ) :: phi_R !< Tracer values (right) [conc] - real, dimension(nk,deg+1), intent(in ) :: ppoly0_coefs_L !< Tracer reconstruction (left) [conc] - real, dimension(nk,deg+1), intent(in ) :: ppoly0_coefs_R !< Tracer reconstruction (right) [conc] - real, dimension(nk,2), intent(in ) :: ppoly0_E_L !< Polynomial edge values (left) [ nondim ] - real, dimension(nk,2), intent(in ) :: ppoly0_E_R !< Polynomial edge values (right) [ nondim ] - integer, intent(in ) :: method !< Method of polynomial integration [ nondim ] + !! layer (right) [H ~> m or kg m-2] + real, intent(in ) :: area_L !< Area of the horizontal grid (left) [L2 ~> m2] + real, intent(in ) :: area_R !< Area of the horizontal grid (right) [L2 ~> m2] + real, dimension(nk), intent(in ) :: phi_L !< Tracer values (left) [conc] + real, dimension(nk), intent(in ) :: phi_R !< Tracer values (right) [conc] + real, dimension(nk,deg+1), intent(in ) :: ppoly0_coefs_L !< Tracer reconstruction (left) [conc] + real, dimension(nk,deg+1), intent(in ) :: ppoly0_coefs_R !< Tracer reconstruction (right) [conc] + real, dimension(nk,2), intent(in ) :: ppoly0_E_L !< Polynomial edge values (left) [nondim] + real, dimension(nk,2), intent(in ) :: ppoly0_E_R !< Polynomial edge values (right) [nondim] + integer, intent(in ) :: method !< Method of polynomial integration [nondim] real, intent(in ) :: khtr_u !< Horizontal diffusivities times delta t !! at a velocity point [L2 ~> m2] real, dimension(nk), intent( out) :: F_layer !< Layerwise diffusive flux at U- or V-point !! [H L2 conc ~> m3 conc] - + logical, optional, intent(in ) :: linear_decay !< If True, apply a linear transition at the base of + !! the boundary layer ! Local variables - real, dimension(nk) :: h_means !< Calculate the layer-wise harmonic means [H ~> m or kg m-2] - real :: khtr_avg !< Thickness-weighted diffusivity at the u-point [m^2 s^-1] + real, dimension(nk) :: h_means !< Calculate the layer-wise harmonic means [H ~> m or kg m-2] + real :: khtr_avg !< Thickness-weighted diffusivity at the u-point [m^2 s^-1] !! This is just to remind developers that khtr_avg should be !! computed once khtr is 3D. real :: heff !< Harmonic mean of layer thicknesses [H ~> m or kg m-2] real :: inv_heff !< Inverse of the harmonic mean of layer thicknesses !! [H-1 ~> m-1 or m2 kg-1] real :: phi_L_avg, phi_R_avg !< Bulk, thickness-weighted tracer averages (left and right column) - !! [conc m^-3 ] + !! [conc m^-3 ] real :: htot !< Total column thickness [H ~> m or kg m-2] - integer :: k, k_bot_min, k_top_max !< k-indices, min and max for top and bottom, respectively + real :: heff_tot !< Total effective column thickness in the transition layer [m] + integer :: k, k_bot_min, k_top_max !< k-indices, min and max for bottom and top, respectively + integer :: k_bot_max, k_top_min !< k-indices, max and min for bottom and top, respectively + integer :: k_bot_diff, k_top_diff !< different between left and right k-indices for bottom and top, respectively integer :: k_top_L, k_bot_L !< k-indices left integer :: k_top_R, k_bot_R !< k-indices right real :: zeta_top_L, zeta_top_R !< distance from the top of a layer to the boundary @@ -472,19 +487,30 @@ subroutine fluxes_layer_method(boundary, nk, deg, h_L, h_R, hbl_L, hbl_R, area_L real :: zeta_bot_L, zeta_bot_R !< distance from the bottom of a layer to the boundary !!layer depth [nondim] real :: h_work_L, h_work_R !< dummy variables - real :: hbl_min !< minimum BLD (left and right) [m] + real :: hbl_min !< minimum BLD (left and right) [m] + real :: wgt !< weight to be used in the linear transition to the interior [nondim] + real :: a !< coefficient to be used in the linear transition to the interior [nondim] + logical :: linear !< True if apply a linear transition F_layer(:) = 0.0 if (hbl_L == 0. .or. hbl_R == 0.) then return endif + linear = .false. + if (PRESENT(linear_decay)) then + linear = linear_decay + endif + ! Calculate vertical indices containing the boundary layer call boundary_k_range(boundary, nk, h_L, hbl_L, k_top_L, zeta_top_L, k_bot_L, zeta_bot_L) call boundary_k_range(boundary, nk, h_R, hbl_R, k_top_R, zeta_top_R, k_bot_R, zeta_bot_R) if (boundary == SURFACE) then k_bot_min = MIN(k_bot_L, k_bot_R) + k_bot_max = MAX(k_bot_L, k_bot_R) + k_bot_diff = (k_bot_max - k_bot_min) + ! make sure left and right k indices span same range if (k_bot_min .ne. k_bot_L) then k_bot_L = k_bot_min @@ -503,15 +529,37 @@ subroutine fluxes_layer_method(boundary, nk, deg, h_L, h_R, hbl_L, hbl_R, area_L heff = harmonic_mean(h_work_L, h_work_R) ! tracer flux where the minimum BLD intersets layer ! GMM, khtr_avg should be computed once khtr is 3D - F_layer(k_bot_min) = -(heff * khtr_u) * (phi_R_avg - phi_L_avg) + if ((linear) .and. (k_bot_diff .gt. 1)) then + ! apply linear decay at the base of hbl + do k = k_bot_min,1,-1 + heff = harmonic_mean(h_L(k), h_R(k)) + F_layer(k) = -(heff * khtr_u) * (phi_R(k) - phi_L(k)) + enddo + ! heff_total + heff_tot = 0.0 + do k = k_bot_min+1,k_bot_max, 1 + heff_tot = heff_tot + harmonic_mean(h_L(k), h_R(k)) + enddo - do k = k_bot_min-1,1,-1 - heff = harmonic_mean(h_L(k), h_R(k)) - F_layer(k) = -(heff * khtr_u) * (phi_R(k) - phi_L(k)) - enddo + a = -1.0/heff_tot + heff_tot = 0.0 + do k = k_bot_min+1,k_bot_max, 1 + heff = harmonic_mean(h_L(k), h_R(k)) + wgt = (a*(heff_tot + (heff * 0.5))) + 1.0 + F_layer(k) = -(heff * khtr_u) * (phi_R(k) - phi_L(k)) * wgt + heff_tot = heff_tot + heff + enddo + else + F_layer(k_bot_min) = -(heff * khtr_u) * (phi_R_avg - phi_L_avg) + do k = k_bot_min-1,1,-1 + heff = harmonic_mean(h_L(k), h_R(k)) + F_layer(k) = -(heff * khtr_u) * (phi_R(k) - phi_L(k)) + enddo + endif endif if (boundary == BOTTOM) then + ! TODO: GMM add option to apply linear decay k_top_max = MAX(k_top_L, k_top_R) ! make sure left and right k indices span same range if (k_top_max .ne. k_top_L) then @@ -544,26 +592,27 @@ end subroutine fluxes_layer_method !> Apply the lateral boundary diffusive fluxes calculated from a 'bulk model' !! See \ref section_method1 subroutine fluxes_bulk_method(boundary, nk, deg, h_L, h_R, hbl_L, hbl_R, area_L, area_R, phi_L, phi_R, ppoly0_coefs_L, & - ppoly0_coefs_R, ppoly0_E_L, ppoly0_E_R, method, khtr_u, F_bulk, F_layer, F_limit) + ppoly0_coefs_R, ppoly0_E_L, ppoly0_E_R, method, khtr_u, F_bulk, F_layer, F_limit, & + linear_decay) integer, intent(in ) :: boundary !< Which boundary layer SURFACE or BOTTOM [nondim] integer, intent(in ) :: nk !< Number of layers [nondim] integer, intent(in ) :: deg !< order of the polynomial reconstruction [nondim] - real, dimension(nk), intent(in ) :: h_L !< Layer thickness (left) [H ~> m or kg m-2] - real, dimension(nk), intent(in ) :: h_R !< Layer thickness (right) [H ~> m or kg m-2] + real, dimension(nk), intent(in ) :: h_L !< Layer thickness (left) [H ~> m or kg m-2] + real, dimension(nk), intent(in ) :: h_R !< Layer thickness (right) [H ~> m or kg m-2] real, intent(in ) :: hbl_L !< Thickness of the boundary boundary - !! layer (left) [H ~> m or kg m-2] + !! layer (left) [H ~> m or kg m-2] real, intent(in ) :: hbl_R !< Thickness of the boundary boundary - !! layer (left) [H ~> m or kg m-2] - real, intent(in ) :: area_L !< Area of the horizontal grid (left) [L2 ~> m2] - real, intent(in ) :: area_R !< Area of the horizontal grid (right) [L2 ~> m2] - real, dimension(nk), intent(in ) :: phi_L !< Tracer values (left) [conc] - real, dimension(nk), intent(in ) :: phi_R !< Tracer values (right) [conc] - real, dimension(nk,deg+1), intent(in ) :: ppoly0_coefs_L !< Tracer reconstruction (left) [conc] - real, dimension(nk,deg+1), intent(in ) :: ppoly0_coefs_R !< Tracer reconstruction (right) [conc] - real, dimension(nk,2), intent(in ) :: ppoly0_E_L !< Polynomial edge values (left) [nondim] - real, dimension(nk,2), intent(in ) :: ppoly0_E_R !< Polynomial edge values (right) [nondim] - integer, intent(in ) :: method !< Method of polynomial integration [nondim] + !! layer (left) [H ~> m or kg m-2] + real, intent(in ) :: area_L !< Area of the horizontal grid (left) [L2 ~> m2] + real, intent(in ) :: area_R !< Area of the horizontal grid (right) [L2 ~> m2] + real, dimension(nk), intent(in ) :: phi_L !< Tracer values (left) [conc] + real, dimension(nk), intent(in ) :: phi_R !< Tracer values (right) [conc] + real, dimension(nk,deg+1), intent(in ) :: ppoly0_coefs_L !< Tracer reconstruction (left) [conc] + real, dimension(nk,deg+1), intent(in ) :: ppoly0_coefs_R !< Tracer reconstruction (right) [conc] + real, dimension(nk,2), intent(in ) :: ppoly0_E_L !< Polynomial edge values (left) [nondim] + real, dimension(nk,2), intent(in ) :: ppoly0_E_R !< Polynomial edge values (right) [nondim] + integer, intent(in ) :: method !< Method of polynomial integration [nondim] real, intent(in ) :: khtr_u !< Horizontal diffusivities times delta t !! at a velocity point [L2 ~> m2] real, intent( out) :: F_bulk !< The bulk mixed layer lateral flux @@ -571,6 +620,8 @@ subroutine fluxes_bulk_method(boundary, nk, deg, h_L, h_R, hbl_L, hbl_R, area_L, real, dimension(nk), intent( out) :: F_layer !< Layerwise diffusive flux at U- or V-point !! [H L2 conc ~> m3 conc] logical, optional, intent(in ) :: F_limit !< If True, apply a limiter + logical, optional, intent(in ) :: linear_decay !< If True, apply a linear transition at the base of + !! the boundary layer ! Local variables real, dimension(nk) :: h_means !< Calculate the layer-wise harmonic means [H ~> m or kg m-2] @@ -578,12 +629,14 @@ subroutine fluxes_bulk_method(boundary, nk, deg, h_L, h_R, hbl_L, hbl_R, area_L, !! This is just to remind developers that khtr_avg should be !! computed once khtr is 3D. real :: heff !< Harmonic mean of layer thicknesses [H ~> m or kg m-2] + real :: heff_tot !< Total effective column thickness in the transition layer [m] real :: inv_heff !< Inverse of the harmonic mean of layer thicknesses !! [H-1 ~> m-1 or m2 kg-1] real :: phi_L_avg, phi_R_avg !< Bulk, thickness-weighted tracer averages (left and right column) !! [conc m^-3 ] - real :: htot !< Total column thickness [H ~> m or kg m-2] + real :: htot ! Total column thickness [H ~> m or kg m-2] integer :: k, k_min, k_max !< k-indices, min and max for top and bottom, respectively + integer :: k_diff !< difference between k_max and k_min integer :: k_top_L, k_bot_L !< k-indices left integer :: k_top_R, k_bot_R !< k-indices right real :: zeta_top_L, zeta_top_R !< distance from the top of a layer to the @@ -594,12 +647,17 @@ subroutine fluxes_bulk_method(boundary, nk, deg, h_L, h_R, hbl_L, hbl_R, area_L, real :: F_max !< The maximum amount of flux that can leave a !! cell [m^3 conc] logical :: limiter !< True if flux limiter should be applied + logical :: linear !< True if apply a linear transition real :: hfrac !< Layer fraction wrt sum of all layers [nondim] real :: dphi !< tracer gradient [conc m^-3] + real :: wgt !< weight to be used in the linear transition to the + !! interior [nondim] + real :: a !< coefficient to be used in the linear transition to the + !! interior [nondim] + F_bulk = 0. + F_layer(:) = 0. if (hbl_L == 0. .or. hbl_R == 0.) then - F_bulk = 0. - F_layer(:) = 0. return endif @@ -607,6 +665,10 @@ subroutine fluxes_bulk_method(boundary, nk, deg, h_L, h_R, hbl_L, hbl_R, area_L, if (PRESENT(F_limit)) then limiter = F_limit endif + linear = .false. + if (PRESENT(linear_decay)) then + linear = linear_decay + endif ! Calculate vertical indices containing the boundary layer call boundary_k_range(boundary, nk, h_L, hbl_L, k_top_L, zeta_top_L, k_bot_L, zeta_bot_L) @@ -617,7 +679,6 @@ subroutine fluxes_bulk_method(boundary, nk, deg, h_L, h_R, hbl_L, hbl_R, area_L, zeta_top_L, k_bot_L, zeta_bot_L) phi_R_avg = bulk_average(boundary, nk, deg, h_R, hbl_R, phi_R, ppoly0_E_R, ppoly0_coefs_R, method, k_top_R, & zeta_top_R, k_bot_R, zeta_bot_R) - ! Calculate the 'bulk' diffusive flux from the bulk averaged quantities ! GMM, khtr_avg should be computed once khtr is 3D heff = harmonic_mean(hbl_L, hbl_R) @@ -625,31 +686,53 @@ subroutine fluxes_bulk_method(boundary, nk, deg, h_L, h_R, hbl_L, hbl_R, area_L, ! Calculate the layerwise sum of the vertical effective thickness. This is different than the heff calculated ! above, but is used as a way to decompose the fluxes onto the individual layers h_means(:) = 0. - if (boundary == SURFACE) then k_min = MIN(k_bot_L, k_bot_R) + k_max = MAX(k_bot_L, k_bot_R) + k_diff = (k_max - k_min) + if ((linear) .and. (k_diff .gt. 1)) then + do k=1,k_min + h_means(k) = harmonic_mean(h_L(k),h_R(k)) + enddo + ! heff_total + heff_tot = 0.0 + do k = k_min+1,k_max, 1 + heff_tot = heff_tot + harmonic_mean(h_L(k), h_R(k)) + enddo - ! left hand side - if (k_bot_L == k_min) then - h_work_L = h_L(k_min) * zeta_bot_L + a = -1.0/heff_tot + heff_tot = 0.0 + ! fluxes will decay linearly at base of hbl + do k = k_min+1,k_max, 1 + heff = harmonic_mean(h_L(k), h_R(k)) + wgt = (a*(heff_tot + (heff * 0.5))) + 1.0 + h_means(k) = harmonic_mean(h_L(k), h_R(k)) * wgt + heff_tot = heff_tot + heff + enddo else - h_work_L = h_L(k_min) - endif + ! left hand side + if (k_bot_L == k_min) then + h_work_L = h_L(k_min) * zeta_bot_L + else + h_work_L = h_L(k_min) + endif - ! right hand side - if (k_bot_R == k_min) then - h_work_R = h_R(k_min) * zeta_bot_R - else - h_work_R = h_R(k_min) - endif + ! right hand side + if (k_bot_R == k_min) then + h_work_R = h_R(k_min) * zeta_bot_R + else + h_work_R = h_R(k_min) + endif - h_means(k_min) = harmonic_mean(h_work_L,h_work_R) + h_means(k_min) = harmonic_mean(h_work_L,h_work_R) - do k=1,k_min-1 - h_means(k) = harmonic_mean(h_L(k),h_R(k)) - enddo + do k=1,k_min-1 + h_means(k) = harmonic_mean(h_L(k),h_R(k)) + enddo + endif elseif (boundary == BOTTOM) then + !TODO, GMM linear decay is not implemented here k_max = MAX(k_top_L, k_top_R) ! left hand side if (k_top_L == k_max) then @@ -672,14 +755,14 @@ subroutine fluxes_bulk_method(boundary, nk, deg, h_L, h_R, hbl_L, hbl_R, area_L, enddo endif - if ( SUM(h_means) == 0. ) then + if ( SUM(h_means) == 0. .or. F_bulk == 0.) then return - ! Decompose the bulk flux onto the individual layers + ! Decompose the bulk flux onto the individual layers else ! Initialize remaining thickness inv_heff = 1./SUM(h_means) do k=1,nk - if (h_means(k) > 0.) then + if ((h_means(k) > 0.) .and. (phi_L(k) /= phi_R(k))) then hfrac = h_means(k)*inv_heff F_layer(k) = F_bulk * hfrac @@ -1035,10 +1118,6 @@ logical function test_layer_fluxes(verbose, nk, test_name, F_calc, F_ans) test_layer_fluxes = .true. write(stdunit,*) "MOM_lateral_boundary_diffusion, UNIT TEST FAILED: ", test_name write(stdunit,10) k, F_calc(k), F_ans(k) - ! ### Once these unit tests are passing, and failures are caught properly, - ! we will post failure notifications to both stdout and stderr. - !write(stderr,*) "MOM_lateral_boundary_diffusion, UNIT TEST FAILED: ", test_name - !write(stderr,10) k, F_calc(k), F_ans(k) elseif (verbose) then write(stdunit,10) k, F_calc(k), F_ans(k) endif From 8fdcd904813686d9250ca48a3fb788339f9d49af Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Wed, 10 Jun 2020 11:12:24 -0600 Subject: [PATCH 296/316] Improve documentation and changed default method * the default LBD method (method # 1) has been changed to the layer by layer approach since this is the recommended scheme. * improve the documentation by adding description of the linear decay option in both methods. --- src/tracer/MOM_lateral_boundary_diffusion.F90 | 125 ++++++++++-------- 1 file changed, 69 insertions(+), 56 deletions(-) diff --git a/src/tracer/MOM_lateral_boundary_diffusion.F90 b/src/tracer/MOM_lateral_boundary_diffusion.F90 index a4b4bcb567..dd2e015632 100644 --- a/src/tracer/MOM_lateral_boundary_diffusion.F90 +++ b/src/tracer/MOM_lateral_boundary_diffusion.F90 @@ -39,13 +39,13 @@ module MOM_lateral_boundary_diffusion type, public :: lateral_boundary_diffusion_CS ; private integer :: method !< Determine which of the three methods calculate !! and apply near boundary layer fluxes - !! 1. Bulk-layer approach - !! 2. Along layer + !! 1. Along layer + !! 2. Bulk-layer approach (not recommended) integer :: deg !< Degree of polynomial reconstruction integer :: surface_boundary_scheme !< Which boundary layer scheme to use !! 1. ePBL; 2. KPP logical :: limiter !< Controls wether a flux limiter is applied. - !! Only valid when method = 1. + !! Only valid when method = 2. logical :: linear !< If True, apply a linear transition at the base/top of the boundary. !! The flux will be fully applied at k=k_min and zero at k=k_max. @@ -105,12 +105,12 @@ logical function lateral_boundary_diffusion_init(Time, G, param_file, diag, diab ! Read all relevant parameters and write them to the model log. call get_param(param_file, mdl, "LATERAL_BOUNDARY_METHOD", CS%method, & "Determine how to apply boundary lateral diffusion of tracers: \n"//& - "1. Bulk layer approach \n"//& - "2. Along layer approach", default=1) - if (CS%method == 1) then + "1. Along layer approach \n"//& + "2. Bulk layer approach (this option is not recommended)", default=1) + if (CS%method == 2) then call get_param(param_file, mdl, "APPLY_LIMITER", CS%limiter, & "If True, apply a flux limiter in the LBD. This is only available \n"//& - "when LATERAL_BOUNDARY_METHOD=1.", default=.false.) + "when LATERAL_BOUNDARY_METHOD=2.", default=.false.) endif call get_param(param_file, mdl, "LBD_LINEAR_TRANSITION", CS%linear, & "If True, apply a linear transition at the base/top of the boundary. \n"//& @@ -191,56 +191,56 @@ subroutine lateral_boundary_diffusion(G, GV, US, h, Coef_x, Coef_y, dt, Reg, CS) uFlx_bulk(:,:) = 0. vFlx_bulk(:,:) = 0. - ! Method #1 - if ( CS%method == 1 ) then + ! Method #1 (layer by layer) + if (CS%method == 1) then do j=G%jsc,G%jec do i=G%isc-1,G%iec if (G%mask2dCu(I,j)>0.) then - call fluxes_bulk_method(SURFACE, GV%ke, CS%deg, h(I,j,:), h(I+1,j,:), hbl(I,j), hbl(I+1,j), & - G%areaT(I,j), G%areaT(I+1,j), tracer%t(I,j,:), tracer%t(I+1,j,:), & - ppoly0_coefs(I,j,:,:), ppoly0_coefs(I+1,j,:,:), ppoly0_E(I,j,:,:), & - ppoly0_E(I+1,j,:,:), remap_method, Coef_x(I,j), uFlx_bulk(I,j), uFlx(I,j,:), CS%limiter, & - CS%linear) + call fluxes_layer_method(SURFACE, GV%ke, CS%deg, h(I,j,:), h(I+1,j,:), hbl(I,j), hbl(I+1,j), & + G%areaT(I,j), G%areaT(I+1,j), tracer%t(I,j,:), tracer%t(I+1,j,:), ppoly0_coefs(I,j,:,:), & + ppoly0_coefs(I+1,j,:,:), ppoly0_E(I,j,:,:), ppoly0_E(I+1,j,:,:), remap_method, Coef_x(I,j), & + uFlx(I,j,:), CS%linear) endif enddo enddo do J=G%jsc-1,G%jec do i=G%isc,G%iec if (G%mask2dCv(i,J)>0.) then - call fluxes_bulk_method(SURFACE, GV%ke, CS%deg, h(i,J,:), h(i,J+1,:), hbl(i,J), hbl(i,J+1), & - G%areaT(i,J), G%areaT(i,J+1), tracer%t(i,J,:), tracer%t(i,J+1,:), & - ppoly0_coefs(i,J,:,:), ppoly0_coefs(i,J+1,:,:), ppoly0_E(i,J,:,:), & - ppoly0_E(i,J+1,:,:), remap_method, Coef_y(i,J), vFlx_bulk(i,J), vFlx(i,J,:), CS%limiter, & - CS%linear) + call fluxes_layer_method(SURFACE, GV%ke, CS%deg, h(i,J,:), h(i,J+1,:), hbl(i,J), hbl(i,J+1), & + G%areaT(i,J), G%areaT(i,J+1), tracer%t(i,J,:), tracer%t(i,J+1,:), ppoly0_coefs(i,J,:,:), & + ppoly0_coefs(i,J+1,:,:), ppoly0_E(i,J,:,:), ppoly0_E(i,J+1,:,:), remap_method, Coef_y(i,J), & + vFlx(i,J,:), CS%linear) endif enddo enddo - ! Post tracer bulk diags - if (tracer%id_lbd_bulk_dfx>0) call post_data(tracer%id_lbd_bulk_dfx, uFlx_bulk*Idt, CS%diag) - if (tracer%id_lbd_bulk_dfy>0) call post_data(tracer%id_lbd_bulk_dfy, vFlx_bulk*Idt, CS%diag) - ! Method #2 + ! Method #2 (bulk approach) elseif (CS%method == 2) then do j=G%jsc,G%jec do i=G%isc-1,G%iec if (G%mask2dCu(I,j)>0.) then - call fluxes_layer_method(SURFACE, GV%ke, CS%deg, h(I,j,:), h(I+1,j,:), hbl(I,j), hbl(I+1,j), & - G%areaT(I,j), G%areaT(I+1,j), tracer%t(I,j,:), tracer%t(I+1,j,:), ppoly0_coefs(I,j,:,:), & - ppoly0_coefs(I+1,j,:,:), ppoly0_E(I,j,:,:), ppoly0_E(I+1,j,:,:), remap_method, Coef_x(I,j), & - uFlx(I,j,:), CS%linear) + call fluxes_bulk_method(SURFACE, GV%ke, CS%deg, h(I,j,:), h(I+1,j,:), hbl(I,j), hbl(I+1,j), & + G%areaT(I,j), G%areaT(I+1,j), tracer%t(I,j,:), tracer%t(I+1,j,:), & + ppoly0_coefs(I,j,:,:), ppoly0_coefs(I+1,j,:,:), ppoly0_E(I,j,:,:), & + ppoly0_E(I+1,j,:,:), remap_method, Coef_x(I,j), uFlx_bulk(I,j), uFlx(I,j,:), CS%limiter, & + CS%linear) endif enddo enddo do J=G%jsc-1,G%jec do i=G%isc,G%iec if (G%mask2dCv(i,J)>0.) then - call fluxes_layer_method(SURFACE, GV%ke, CS%deg, h(i,J,:), h(i,J+1,:), hbl(i,J), hbl(i,J+1), & - G%areaT(i,J), G%areaT(i,J+1), tracer%t(i,J,:), tracer%t(i,J+1,:), ppoly0_coefs(i,J,:,:), & - ppoly0_coefs(i,J+1,:,:), ppoly0_E(i,J,:,:), ppoly0_E(i,J+1,:,:), remap_method, Coef_y(i,J), & - vFlx(i,J,:), CS%linear) + call fluxes_bulk_method(SURFACE, GV%ke, CS%deg, h(i,J,:), h(i,J+1,:), hbl(i,J), hbl(i,J+1), & + G%areaT(i,J), G%areaT(i,J+1), tracer%t(i,J,:), tracer%t(i,J+1,:), & + ppoly0_coefs(i,J,:,:), ppoly0_coefs(i,J+1,:,:), ppoly0_E(i,J,:,:), & + ppoly0_E(i,J+1,:,:), remap_method, Coef_y(i,J), vFlx_bulk(i,J), vFlx(i,J,:), CS%limiter, & + CS%linear) endif enddo enddo + ! Post tracer bulk diags + if (tracer%id_lbd_bulk_dfx>0) call post_data(tracer%id_lbd_bulk_dfx, uFlx_bulk*Idt, CS%diag) + if (tracer%id_lbd_bulk_dfy>0) call post_data(tracer%id_lbd_bulk_dfy, vFlx_bulk*Idt, CS%diag) endif ! Update the tracer fluxes @@ -436,7 +436,7 @@ end subroutine boundary_k_range !> Calculate the lateral boundary diffusive fluxes using the layer by layer method. -!! See \ref section_method2 +!! See \ref section_method1 subroutine fluxes_layer_method(boundary, nk, deg, h_L, h_R, hbl_L, hbl_R, area_L, area_R, phi_L, phi_R, & ppoly0_coefs_L, ppoly0_coefs_R, ppoly0_E_L, ppoly0_E_R, method, khtr_u, & F_layer, linear_decay) @@ -590,7 +590,7 @@ subroutine fluxes_layer_method(boundary, nk, deg, h_L, h_R, hbl_L, hbl_R, area_L end subroutine fluxes_layer_method !> Apply the lateral boundary diffusive fluxes calculated from a 'bulk model' -!! See \ref section_method1 +!! See \ref section_method2 subroutine fluxes_bulk_method(boundary, nk, deg, h_L, h_R, hbl_L, hbl_R, area_L, area_R, phi_L, phi_R, ppoly0_coefs_L, & ppoly0_coefs_R, ppoly0_E_L, ppoly0_E_R, method, khtr_u, F_bulk, F_layer, F_limit, & linear_decay) @@ -1175,12 +1175,37 @@ end function test_boundary_k_range !! !! Boundary lateral diffusion can be applied using one of the three methods: !! -!! * [Method #1: Bulk layer](@ref section_method1) (default); -!! * [Method #2: Along layer](@ref section_method2); +!! * [Method #1: Along layer](@ref section_method2) (default); +!! * [Method #2: Bulk layer](@ref section_method1); !! !! A brief summary of these methods is provided below. !! -!! \subsection section_method1 Bulk layer approach (Method #1) +!! \subsection section_method1 Along layer approach (Method #1) +!! +!! This is the recommended and more straight forward method where diffusion is +!! applied layer by layer using only information from neighboring cells. +!! +!! Step #1: compute vertical indices containing boundary layer (boundary_k_range). +!! For the TOP boundary layer, these are: +!! +!! k_top, k_bot, zeta_top, zeta_bot +!! +!! Step #2: calculate the diffusive flux at each layer: +!! +!! \f[ F_{k} = -KHTR \times h_{eff}(k) \times (\phi_R(k) - \phi_L(k)), \f] +!! where h_eff is the [harmonic mean](@ref section_harmonic_mean) of the layer thickness +!! in the left and right columns. This method does not require a limiter since KHTR +!! is already limted based on a diffusive CFL condition prior to the call of this +!! module. +!! +!! Step #3: option to linearly decay the flux from k_bot_min to k_bot_max: +!! +!! If LBD_LINEAR_TRANSITION = True and k_bot_diff > 1, the diffusive flux will decay +!! linearly between the top interface of the layer containing the minimum boundary +!! layer depth (k_bot_min) and the lower interface of the layer containing the +!! maximum layer depth (k_bot_max). +!! +!! \subsection section_method2 Bulk layer approach (Method #2) !! !! Apply the lateral boundary diffusive fluxes calculated from a 'bulk model'.This !! is a lower order representation (Kraus-Turner like approach) which assumes that @@ -1210,7 +1235,14 @@ end function test_boundary_k_range !! h_u is the [harmonic mean](@ref section_harmonic_mean) of thicknesses at each layer. !! Special care (layer reconstruction) must be taken at k_min = min(k_botL, k_bot_R). !! -!! Step #4: limit the tracer flux so that 1) only down-gradient fluxes are applied, +!! Step #4: option to linearly decay the flux from k_bot_min to k_bot_max: +!! +!! If LBD_LINEAR_TRANSITION = True and k_bot_diff > 1, the diffusive flux will decay +!! linearly between the top interface of the layer containing the minimum boundary +!! layer depth (k_bot_min) and the lower interface of the layer containing the +!! maximum layer depth (k_bot_max). +!! +!! Step #5: limit the tracer flux so that 1) only down-gradient fluxes are applied, !! and 2) the flux cannot be larger than F_max, which is defined using the tracer !! gradient: !! @@ -1221,25 +1253,6 @@ end function test_boundary_k_range !! 0 1 0 .2.2.2 !! 0 .2 !! -!! \subsection section_method2 Along layer approach (Method #2) -!! -!! This is a more straight forward method where diffusion is applied layer by layer using -!! only information from neighboring cells. -!! -!! Step #1: compute vertical indices containing boundary layer (boundary_k_range). -!! For the TOP boundary layer, these are: -!! -!! k_top, k_bot, zeta_top, zeta_bot -!! -!! Step #2: calculate the diffusive flux at each layer: -!! -!! \f[ F_{k} = -KHTR \times h_{eff}(k) \times (\phi_R(k) - \phi_L(k)), \f] -!! where h_eff is the [harmonic mean](@ref section_harmonic_mean) of the layer thickness -!! in the left and right columns. Special care (layer reconstruction) must be taken at -!! k_min = min(k_botL, k_bot_R). This method does not require a limiter since KHTR -!! is already limted based on a diffusive CFL condition prior to the call of this -!! module. -!! !! \subsection section_harmonic_mean Harmonic Mean !! !! The harmonic mean (HM) betwen h1 and h2 is defined as: From ca86bad5109e9c77d5512d758ec5013f8d0b4fb5 Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Wed, 10 Jun 2020 14:23:27 -0600 Subject: [PATCH 297/316] Remove trailing space --- config_src/nuopc_driver/mom_cap.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/config_src/nuopc_driver/mom_cap.F90 b/config_src/nuopc_driver/mom_cap.F90 index 232a97ad41..55722a3ad9 100644 --- a/config_src/nuopc_driver/mom_cap.F90 +++ b/config_src/nuopc_driver/mom_cap.F90 @@ -72,7 +72,7 @@ module MOM_cap_mod use ESMF, only: ESMF_ArrayCreate use ESMF, only: ESMF_RC_FILE_OPEN, ESMF_RC_FILE_READ, ESMF_RC_FILE_WRITE use ESMF, only: ESMF_VMBroadcast -use ESMF, only: ESMF_AlarmCreate, ESMF_ClockGetAlarmList, ESMF_AlarmList_Flag +use ESMF, only: ESMF_AlarmCreate, ESMF_ClockGetAlarmList, ESMF_AlarmList_Flag use ESMF, only: ESMF_AlarmGet, ESMF_AlarmIsCreated, ESMF_ALARMLIST_ALL, ESMF_AlarmIsEnabled use ESMF, only: ESMF_STATEITEM_NOTFOUND, ESMF_FieldWrite use ESMF, only: operator(==), operator(/=), operator(+), operator(-) @@ -2063,7 +2063,7 @@ subroutine ModelSetRunClock(gcomp, rc) call ESMF_LogWrite(subname//" Create Stop alarm", ESMF_LOGMSG_INFO, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & line=__LINE__, file=__FILE__)) return - + call ESMF_TimeGet(dstoptime, timestring=timestr, rc=rc) call ESMF_LogWrite("Stop Alarm will ring at : "//trim(timestr), ESMF_LOGMSG_INFO, rc=rc) From 388b100c8b04e501e0685952cb9e4c3b7aa7299d Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Wed, 17 Jun 2020 16:06:14 -0600 Subject: [PATCH 298/316] Fix default zeta_bot values --- src/tracer/MOM_neutral_diffusion.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/tracer/MOM_neutral_diffusion.F90 b/src/tracer/MOM_neutral_diffusion.F90 index 890bae928c..d60aade72b 100644 --- a/src/tracer/MOM_neutral_diffusion.F90 +++ b/src/tracer/MOM_neutral_diffusion.F90 @@ -312,7 +312,7 @@ subroutine neutral_diffusion_calc_coeffs(G, GV, US, h, T, S, CS, p_surf) pa_to_H = 1. / (GV%H_to_RZ * GV%g_Earth) k_top(:,:) = 1 ; k_bot(:,:) = 1 - zeta_top(:,:) = 0. ; zeta_bot(:,:) = 1. + zeta_top(:,:) = 0. ; zeta_bot(:,:) = 0. ! Check if hbl needs to be extracted if (CS%interior_only) then From cbcf3ec9b19c6e35ea836b1d5cf1bacebbdc414a Mon Sep 17 00:00:00 2001 From: jiandewang Date: Fri, 10 Jul 2020 23:34:22 -0400 Subject: [PATCH 299/316] bug fixing: (1) add missing halo in MOM_full_convection.F90 (2) remove wrong logic "not" in MOM.F90 at line 2669 --- src/core/MOM.F90 | 2 +- src/parameterizations/vertical/MOM_full_convection.F90 | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index a044f95893..4c3d6bd250 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -2666,7 +2666,7 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & call register_obsolete_diagnostics(param_file, CS%diag) if (use_frazil) then - if (.not.query_initialized(CS%tv%frazil,"frazil",restart_CSp)) then + if (query_initialized(CS%tv%frazil,"frazil",restart_CSp)) then ! Test whether the dimensional rescaling has changed for heat content. if ((US%kg_m3_to_R_restart*US%m_to_Z_restart*US%J_kg_to_Q_restart /= 0.0) .and. & ((US%J_kg_to_Q*US%kg_m3_to_R*US%m_to_Z) /= & diff --git a/src/parameterizations/vertical/MOM_full_convection.F90 b/src/parameterizations/vertical/MOM_full_convection.F90 index 1783955d53..3be6628b14 100644 --- a/src/parameterizations/vertical/MOM_full_convection.F90 +++ b/src/parameterizations/vertical/MOM_full_convection.F90 @@ -408,7 +408,7 @@ subroutine smoothed_dRdT_dRdS(h, tv, Kddt, dR_dT, dR_dS, G, GV, US, j, p_surf, h else do i=is,ie ; pres(i) = 0.0 ; enddo endif - EOSdom(:) = EOS_domain(G%HI) + EOSdom(:) = EOS_domain(G%HI, halo) call calculate_density_derivs(T_f(:,1), S_f(:,1), pres, dR_dT(:,1), dR_dS(:,1), tv%eqn_of_state, EOSdom) do i=is,ie ; pres(i) = pres(i) + h(i,j,1)*(GV%H_to_RZ*GV%g_Earth) ; enddo do K=2,nz From 2fe90f2fe60779f2036d6c921c6ef37cc58d49df Mon Sep 17 00:00:00 2001 From: alperaltuntas Date: Tue, 4 Aug 2020 15:09:59 -0600 Subject: [PATCH 300/316] retrieve num_rest_files from save_restart --- src/framework/MOM_restart.F90 | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/src/framework/MOM_restart.F90 b/src/framework/MOM_restart.F90 index c918f3a9ee..20056c15ad 100644 --- a/src/framework/MOM_restart.F90 +++ b/src/framework/MOM_restart.F90 @@ -849,7 +849,7 @@ 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) +subroutine save_restart(directory, time, G, CS, time_stamped, filename, GV, num_rest_files) 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 @@ -860,6 +860,7 @@ subroutine save_restart(directory, time, G, CS, time_stamped, filename, GV) !! 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 + integer, optional, intent(out) :: num_rest_files !< number of restart files written ! Local variables type(vardesc) :: vars(CS%max_fields) ! Descriptions of the fields that @@ -1056,6 +1057,9 @@ subroutine save_restart(directory, time, G, CS, time_stamped, filename, GV) num_files = num_files+1 enddo + + if (present(num_rest_files)) num_rest_files = num_files + end subroutine save_restart !> restore_state reads the model state from previously generated files. All From ff27ad56068ad121ba803db80cf8d4abdbd850a0 Mon Sep 17 00:00:00 2001 From: alperaltuntas Date: Tue, 4 Aug 2020 15:11:09 -0600 Subject: [PATCH 301/316] add num_rest_files to ocean_model_restart --- config_src/nuopc_driver/mom_ocean_model_nuopc.F90 | 12 +++++++++--- 1 file changed, 9 insertions(+), 3 deletions(-) diff --git a/config_src/nuopc_driver/mom_ocean_model_nuopc.F90 b/config_src/nuopc_driver/mom_ocean_model_nuopc.F90 index aabf456ca8..cbbb2261d0 100644 --- a/config_src/nuopc_driver/mom_ocean_model_nuopc.F90 +++ b/config_src/nuopc_driver/mom_ocean_model_nuopc.F90 @@ -671,7 +671,7 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, & end subroutine update_ocean_model !> This subroutine writes out the ocean model restart file. -subroutine ocean_model_restart(OS, timestamp, restartname) +subroutine ocean_model_restart(OS, timestamp, restartname, num_rest_files) 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 @@ -679,6 +679,7 @@ subroutine ocean_model_restart(OS, timestamp, restartname) character(len=*), optional, intent(in) :: restartname !< Name of restart file to use !! This option distinguishes the cesm interface from the !! non-cesm interface + integer, optional, intent(out) :: num_rest_files !< number of restart files written if (.not.MOM_state_is_synchronized(OS%MOM_CSp)) & call MOM_error(WARNING, "End of MOM_main reached with inconsistent "//& @@ -689,8 +690,13 @@ subroutine ocean_model_restart(OS, timestamp, restartname) "restart files can only be created after the buoyancy forcing is applied.") if (present(restartname)) then - call save_restart(OS%dirs%restart_output_dir, OS%Time, OS%grid, & - OS%restart_CSp, GV=OS%GV, filename=restartname) + if (present(num_rest_files)) then + call save_restart(OS%dirs%restart_output_dir, OS%Time, OS%grid, & + OS%restart_CSp, GV=OS%GV, filename=restartname, num_rest_files=num_rest_files) + else + call save_restart(OS%dirs%restart_output_dir, OS%Time, OS%grid, & + OS%restart_CSp, GV=OS%GV, filename=restartname) + endif call forcing_save_restart(OS%forcing_CSp, OS%grid, OS%Time, & OS%dirs%restart_output_dir) ! Is this needed? if (OS%use_ice_shelf) then From 4c609001073b7ae9624d9afc8f6a5ddf528ef8c1 Mon Sep 17 00:00:00 2001 From: alperaltuntas Date: Tue, 4 Aug 2020 15:15:02 -0600 Subject: [PATCH 302/316] read/write multiple restart filenames from/to rpointer files --- config_src/nuopc_driver/mom_cap.F90 | 67 +++++++++++++++++++++-------- 1 file changed, 49 insertions(+), 18 deletions(-) diff --git a/config_src/nuopc_driver/mom_cap.F90 b/config_src/nuopc_driver/mom_cap.F90 index 6ea8620621..ebb4c7f277 100644 --- a/config_src/nuopc_driver/mom_cap.F90 +++ b/config_src/nuopc_driver/mom_cap.F90 @@ -464,6 +464,8 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) integer :: iostat integer :: readunit character(len=512) :: restartfile ! Path/Name of restart file + character(len=512) :: restartfiles ! Path/Name of restart files + ! (same as restartfile if single restart file) character(len=*), parameter :: subname='(MOM_cap:InitializeAdvertise)' character(len=32) :: calendar !-------------------------------- @@ -653,10 +655,10 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) return endif - restartfile = "" + restartfile = ""; restartfiles = "" if (runtype == "initial") then - restartfile = "n" + restartfiles = "n" else if (runtype == "continue") then ! hybrid or branch or continuos runs @@ -675,16 +677,23 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) line=__LINE__, file=u_FILE_u, rcToReturn=rc) return endif - read(readunit,'(a)', iostat=iostat) restartfile - if (iostat /= 0) then - call ESMF_LogSetError(ESMF_RC_FILE_READ, msg=subname//' ERROR reading rpointer.ocn', & - line=__LINE__, file=u_FILE_u, rcToReturn=rc) - return - endif + do + read(readunit,'(a)', iostat=iostat) restartfile + if (iostat /= 0) then + if (len(trim(restartfiles))>1 .and. iostat<0) then + exit ! done reading restart files list. + else + call ESMF_LogSetError(ESMF_RC_FILE_READ, msg=subname//' ERROR reading rpointer.ocn', & + line=__LINE__, file=u_FILE_u, rcToReturn=rc) + return + endif + endif + restartfiles = trim(restartfiles) // " " // trim(restartfile) + enddo close(readunit) endif ! broadcast attribute set on master task to all tasks - call ESMF_VMBroadcast(vm, restartfile, count=ESMF_MAXSTR-1, rootPet=0, rc=rc) + call ESMF_VMBroadcast(vm, restartfiles, count=ESMF_MAXSTR-1, rootPet=0, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return else call ESMF_LogWrite('MOM_cap: restart requested, use input.nml', ESMF_LOGMSG_WARNING) @@ -693,7 +702,7 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) endif ocean_public%is_ocean_pe = .true. - call ocean_model_init(ocean_public, ocean_state, time0, time_start, input_restart_file=trim(restartfile)) + call ocean_model_init(ocean_public, ocean_state, time0, time_start, input_restart_file=trim(restartfiles)) call ocean_model_init_sfc(ocean_state, ocean_public) @@ -1611,10 +1620,12 @@ subroutine ModelAdvance(gcomp, rc) integer :: writeunit integer :: localPet type(ESMF_VM) :: vm - integer :: n + integer :: n, i character(240) :: import_timestr, export_timestr character(len=128) :: fldname character(len=*),parameter :: subname='(MOM_cap:ModelAdvance)' + character(len=8) :: suffix + integer :: num_rest_files rc = ESMF_SUCCESS if(profile_memory) call ESMF_VMLogMemInfo("Entering MOM Model_ADVANCE: ") @@ -1832,6 +1843,12 @@ subroutine ModelAdvance(gcomp, rc) write(restartname,'(A,".mom6.r.",I4.4,"-",I2.2,"-",I2.2,"-",I5.5)') & trim(casename), year, month, day, seconds + + call ESMF_LogWrite("MOM_cap: Writing restart : "//trim(restartname), ESMF_LOGMSG_INFO, rc=rc) + + ! write restart file(s) + call ocean_model_restart(ocean_state, restartname=restartname, num_rest_files=num_rest_files) + if (localPet == 0) then ! Write name of restart file in the rpointer file - this is currently hard-coded for the ocean open(newunit=writeunit, file='rpointer.ocn', form='formatted', status='unknown', iostat=iostat) @@ -1841,6 +1858,19 @@ subroutine ModelAdvance(gcomp, rc) return endif write(writeunit,'(a)') trim(restartname)//'.nc' + + if (num_rest_files > 1) then + ! append i.th restart file name to rpointer + do i=2, num_rest_files + if (num_rest_files < 10) then + write(suffix,'("_",I1)') i + else + write(suffix,'("_",I2)') i + endif + write(writeunit,'(a)') trim(restartname) // trim(suffix) // '.nc' + enddo + endif + close(writeunit) endif else @@ -1851,16 +1881,17 @@ subroutine ModelAdvance(gcomp, rc) write(restartname,'(A,I4.4,"-",I2.2,"-",I2.2,"-",I2.2,"-",I2.2,"-",I2.2)') & "MOM.res.", year, month, day, hour, minute, seconds endif - end if - call ESMF_LogWrite("MOM_cap: Writing restart : "//trim(restartname), ESMF_LOGMSG_INFO, rc=rc) - ! write restart file(s) - call ocean_model_restart(ocean_state, restartname=restartname) + call ESMF_LogWrite("MOM_cap: Writing restart : "//trim(restartname), ESMF_LOGMSG_INFO, rc=rc) - if (is_root_pe()) then - write(logunit,*) subname//' writing restart file ',trim(restartname) - endif + ! write restart file(s) + call ocean_model_restart(ocean_state, restartname=restartname) + end if + + if (is_root_pe()) then + write(logunit,*) subname//' writing restart file ',trim(restartname) endif + endif !--------------- ! Write diagnostics From 7a2256c50e6b70517993952061a79498bf9cfde0 Mon Sep 17 00:00:00 2001 From: alperaltuntas Date: Tue, 4 Aug 2020 18:14:57 -0600 Subject: [PATCH 303/316] correct restart file suffix index --- config_src/nuopc_driver/mom_cap.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/config_src/nuopc_driver/mom_cap.F90 b/config_src/nuopc_driver/mom_cap.F90 index ebb4c7f277..4455ce7fdc 100644 --- a/config_src/nuopc_driver/mom_cap.F90 +++ b/config_src/nuopc_driver/mom_cap.F90 @@ -1861,7 +1861,7 @@ subroutine ModelAdvance(gcomp, rc) if (num_rest_files > 1) then ! append i.th restart file name to rpointer - do i=2, num_rest_files + do i=1, num_rest_files-1 if (num_rest_files < 10) then write(suffix,'("_",I1)') i else From 4c91ae3ac2fbf2d1a1c914b919bfb1baa8d6b6e2 Mon Sep 17 00:00:00 2001 From: alperaltuntas Date: Wed, 5 Aug 2020 14:32:27 -0600 Subject: [PATCH 304/316] add filename length check --- config_src/nuopc_driver/mom_cap.F90 | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/config_src/nuopc_driver/mom_cap.F90 b/config_src/nuopc_driver/mom_cap.F90 index 4455ce7fdc..312d2397e7 100644 --- a/config_src/nuopc_driver/mom_cap.F90 +++ b/config_src/nuopc_driver/mom_cap.F90 @@ -688,6 +688,10 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) return endif endif + ! check if the length of restartfiles variable is sufficient: + if (len(restartfiles)-len(trim(restartfiles)) < len(trim(restartfile))) then + call MOM_error(FATAL, "Restart file name(s) too long.") + endif restartfiles = trim(restartfiles) // " " // trim(restartfile) enddo close(readunit) @@ -1862,7 +1866,7 @@ subroutine ModelAdvance(gcomp, rc) if (num_rest_files > 1) then ! append i.th restart file name to rpointer do i=1, num_rest_files-1 - if (num_rest_files < 10) then + if (i < 10) then write(suffix,'("_",I1)') i else write(suffix,'("_",I2)') i From 0a5515b3dbe647b13e28801ed70b71aa66ca0149 Mon Sep 17 00:00:00 2001 From: alperaltuntas Date: Wed, 5 Aug 2020 16:54:29 -0600 Subject: [PATCH 305/316] increase restart filename lengths --- src/framework/MOM_get_input.F90 | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/src/framework/MOM_get_input.F90 b/src/framework/MOM_get_input.F90 index ad48086543..b6b5b89be9 100644 --- a/src/framework/MOM_get_input.F90 +++ b/src/framework/MOM_get_input.F90 @@ -21,7 +21,8 @@ module MOM_get_input character(len=240) :: & restart_input_dir = ' ',& !< The directory to read restart and input files. restart_output_dir = ' ',&!< The directory into which to write restart files. - output_directory = ' ', & !< The directory to use to write the model output. + output_directory = ' ' !< The directory to use to write the model output. + character(len=2048) :: & input_filename = ' ' !< A string that indicates the input files or how !! the run segment should be started. end type directories @@ -46,7 +47,8 @@ subroutine get_MOM_input(param_file, dirs, check_params, default_input_filename, parameter_filename(npf), & ! List of files containing parameters. output_directory, & ! Directory to use to write the model output. restart_input_dir, & ! Directory for reading restart and input files. - restart_output_dir, & ! Directory into which to write restart files. + restart_output_dir ! Directory into which to write restart files. + character(len=2048) :: & input_filename ! A string that indicates the input files or how ! the run segment should be started. character(len=240) :: output_dir From bba3e91b51108b19a0fd826b044faefdf0cc4466 Mon Sep 17 00:00:00 2001 From: alperaltuntas Date: Wed, 5 Aug 2020 16:55:23 -0600 Subject: [PATCH 306/316] increase nuopc cap restart filename length --- config_src/nuopc_driver/mom_cap.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/config_src/nuopc_driver/mom_cap.F90 b/config_src/nuopc_driver/mom_cap.F90 index 312d2397e7..c2a2e98838 100644 --- a/config_src/nuopc_driver/mom_cap.F90 +++ b/config_src/nuopc_driver/mom_cap.F90 @@ -464,7 +464,7 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) integer :: iostat integer :: readunit character(len=512) :: restartfile ! Path/Name of restart file - character(len=512) :: restartfiles ! Path/Name of restart files + character(len=2048) :: restartfiles ! Path/Name of restart files ! (same as restartfile if single restart file) character(len=*), parameter :: subname='(MOM_cap:InitializeAdvertise)' character(len=32) :: calendar @@ -697,7 +697,7 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) close(readunit) endif ! broadcast attribute set on master task to all tasks - call ESMF_VMBroadcast(vm, restartfiles, count=ESMF_MAXSTR-1, rootPet=0, rc=rc) + call ESMF_VMBroadcast(vm, restartfiles, count=len(restartfiles), rootPet=0, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return else call ESMF_LogWrite('MOM_cap: restart requested, use input.nml', ESMF_LOGMSG_WARNING) From 829aadea92f5abecfe6ce647583b2d20e636cb77 Mon Sep 17 00:00:00 2001 From: alperaltuntas Date: Wed, 5 Aug 2020 17:13:06 -0600 Subject: [PATCH 307/316] make mct cap be able to write multiple restart files to rpointer --- config_src/mct_driver/ocn_comp_mct.F90 | 19 ++++++++++++++++++- 1 file changed, 18 insertions(+), 1 deletion(-) diff --git a/config_src/mct_driver/ocn_comp_mct.F90 b/config_src/mct_driver/ocn_comp_mct.F90 index b1ce9a60c0..9466159948 100644 --- a/config_src/mct_driver/ocn_comp_mct.F90 +++ b/config_src/mct_driver/ocn_comp_mct.F90 @@ -434,6 +434,9 @@ subroutine ocn_run_mct( EClock, cdata_o, x2o_o, o2x_o) integer :: ocn_cpl_dt !< one ocn coupling interval in seconds. (to be received from cesm) real (kind=8) :: mom_cpl_dt !< one ocn coupling interval in seconds. (internal) integer :: ncouple_per_day !< number of ocean coupled call in one day (non-dim) + integer :: num_rest_files !< number of restart files written + integer :: i + character(len=8) :: suffix ! reset shr logging to ocn log file: if (is_root_pe()) then @@ -534,7 +537,8 @@ 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, & + num_rest_files=num_rest_files) ! write name of restart file in the rpointer file nu = shr_file_getUnit() @@ -542,6 +546,19 @@ subroutine ocn_run_mct( EClock, cdata_o, x2o_o, o2x_o) restart_pointer_file = trim(glb%pointer_filename) open(nu, file=restart_pointer_file, form='formatted', status='unknown') write(nu,'(a)') trim(restartname) //'.nc' + + if (num_rest_files > 1) then + ! append i.th restart file name to rpointer + do i=1, num_rest_files-1 + if (i < 10) then + write(suffix,'("_",I1)') i + else + write(suffix,'("_",I2)') i + endif + write(nu,'(a)') trim(restartname) // trim(suffix) // '.nc' + enddo + endif + close(nu) write(glb%stdout,*) 'ocn restart pointer file written: ',trim(restartname) endif From 648bb1ce86f19aa3577d21865c393b0537cf5b77 Mon Sep 17 00:00:00 2001 From: alperaltuntas Date: Wed, 5 Aug 2020 17:35:55 -0600 Subject: [PATCH 308/316] make mct cap be able to read multiple restart files from rpointer --- config_src/mct_driver/ocn_comp_mct.F90 | 25 ++++++++++++++++++++----- 1 file changed, 20 insertions(+), 5 deletions(-) diff --git a/config_src/mct_driver/ocn_comp_mct.F90 b/config_src/mct_driver/ocn_comp_mct.F90 index 9466159948..741ce832e8 100644 --- a/config_src/mct_driver/ocn_comp_mct.F90 +++ b/config_src/mct_driver/ocn_comp_mct.F90 @@ -119,7 +119,9 @@ subroutine ocn_init_mct( EClock, cdata_o, x2o_o, o2x_o, NLFilename ) 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 + character(len=512) :: restartfile !< Path/Name of restart file + character(len=2048) :: restartfiles !< Path/Name of restart files. + !! (same as restartfile if a single restart file is to be read in) 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 @@ -164,6 +166,7 @@ subroutine ocn_init_mct( EClock, cdata_o, x2o_o, o2x_o, NLFilename ) !logical :: lsend_precip_fact !< If T,send precip_fact to cpl for use in fw balance !! (partially-coupled option) character(len=128) :: err_msg !< Error message + integer :: iostat ! set the cdata pointers: call seq_cdata_setptrs(cdata_o, id=MOM_MCT_ID, mpicom=mpicom_ocn, & @@ -296,15 +299,27 @@ subroutine ocn_init_mct( EClock, cdata_o, x2o_o, o2x_o, NLFilename ) nu = shr_file_getUnit() restart_pointer_file = trim(glb%pointer_filename) if (is_root_pe()) write(glb%stdout,*) 'Reading ocn pointer file: ',restart_pointer_file + restartfile = ""; restartfiles = ""; open(nu, file=restart_pointer_file, form='formatted', status='unknown') - read(nu,'(a)') restartfile + do + read(nu,'(a)', iostat=iostat) restartfile + if (len(trim(restartfiles))>1 .and. iostat<0) then + exit ! done reading restart files list. + else if (iostat/=0) then + call MOM_error(FATAL, 'Error reading rpointer.ocn') + endif + ! check if the length of restartfiles variable is sufficient: + if (len(restartfiles)-len(trim(restartfiles)) < len(trim(restartfile))) then + call MOM_error(FATAL, "Restart file name(s) too long.") + endif + restartfiles = trim(restartfiles) // " " // trim(restartfile) + enddo close(nu) - !restartfile = trim(restartpath) // trim(restartfile) if (is_root_pe()) then - write(glb%stdout,*) 'Reading restart file: ',trim(restartfile) + write(glb%stdout,*) 'Reading restart file(s): ',trim(restartfiles) end if call shr_file_freeUnit(nu) - call ocean_model_init(glb%ocn_public, glb%ocn_state, time0, time_start, input_restart_file=trim(restartfile)) + call ocean_model_init(glb%ocn_public, glb%ocn_state, time0, time_start, input_restart_file=trim(restartfiles)) endif if (is_root_pe()) then write(glb%stdout,'(/12x,a/)') '======== COMPLETED MOM INITIALIZATION ========' From 7e1188c7221076acfabe877b6ca919eb42c7a07b Mon Sep 17 00:00:00 2001 From: Denise Worthen Date: Thu, 6 Aug 2020 16:57:53 -0400 Subject: [PATCH 309/316] add statediagnose feature (#31) --- config_src/nuopc_driver/mom_cap.F90 | 35 +++- config_src/nuopc_driver/mom_cap_methods.F90 | 183 +++++++++++++++++++- 2 files changed, 210 insertions(+), 8 deletions(-) diff --git a/config_src/nuopc_driver/mom_cap.F90 b/config_src/nuopc_driver/mom_cap.F90 index a8056129ff..d49f370a47 100644 --- a/config_src/nuopc_driver/mom_cap.F90 +++ b/config_src/nuopc_driver/mom_cap.F90 @@ -26,7 +26,7 @@ module MOM_cap_mod use time_manager_mod, only: fms_get_calendar_type => get_calendar_type use MOM_domains, only: MOM_infra_init, num_pes, root_pe, pe_here use MOM_file_parser, only: get_param, log_version, param_file_type, close_param_file -use MOM_get_input, only: Get_MOM_Input, directories +use MOM_get_input, only: get_MOM_input, directories use MOM_domains, only: pass_var use MOM_error_handler, only: MOM_error, FATAL, is_root_pe use MOM_ocean_model_nuopc, only: ice_ocean_boundary_type @@ -36,7 +36,7 @@ module MOM_cap_mod use MOM_ocean_model_nuopc, only: ocean_model_init, update_ocean_model, ocean_model_end use MOM_ocean_model_nuopc, only: get_ocean_grid, get_eps_omesh use MOM_cap_time, only: AlarmInit -use MOM_cap_methods, only: mom_import, mom_export, mom_set_geomtype +use MOM_cap_methods, only: mom_import, mom_export, mom_set_geomtype, state_diagnose #ifdef CESMCOUPLED use shr_file_mod, only: shr_file_setLogUnit, shr_file_getLogUnit #endif @@ -124,7 +124,7 @@ module MOM_cap_mod integer :: fldsFrOcn_num = 0 type (fld_list_type) :: fldsFrOcn(fldsMax) -integer :: debug = 0 +integer :: dbug = 0 integer :: import_slice = 1 integer :: export_slice = 1 character(len=256) :: tmpstr @@ -273,6 +273,14 @@ subroutine InitializeP0(gcomp, importState, exportState, clock, rc) write(logmsg,*) grid_attach_area call ESMF_LogWrite('MOM_cap:GridAttachArea = '//trim(logmsg), ESMF_LOGMSG_INFO) + call NUOPC_CompAttributeGet(gcomp, name='dbug_flag', value=value, isPresent=isPresent, isSet=isSet, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (isPresent .and. isSet) then + read(value,*) dbug + end if + write(logmsg,'(i6)') dbug + call ESMF_LogWrite('MOM_cap:dbug = '//trim(logmsg), ESMF_LOGMSG_INFO) + scalar_field_name = "" call NUOPC_CompAttributeGet(gcomp, name="ScalarFieldName", value=value, & isPresent=isPresent, isSet=isSet, rc=rc) @@ -358,6 +366,7 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) type(ice_ocean_boundary_type), pointer :: Ice_ocean_boundary => NULL() type(ocean_internalstate_wrapper) :: ocean_internalstate type(ocean_grid_type), pointer :: ocean_grid => NULL() + type(directories) :: dirs type(time_type) :: Run_len !< length of experiment type(time_type) :: time0 !< Start time of coupled model's calendar. type(time_type) :: time_start !< The time at which to initialize the ocean model @@ -520,8 +529,13 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) restartfile = "" if (runtype == "initial") then - - restartfile = "n" + if (cesm_coupled) then + restartfile = "n" + else + call get_MOM_input(dirs=dirs) + restartfile = dirs%input_filename(1:1) + endif + call ESMF_LogWrite('MOM_cap:restartfile = '//trim(restartfile), ESMF_LOGMSG_INFO) else if (runtype == "continue") then ! hybrid or branch or continuos runs @@ -821,7 +835,7 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) allocate(xb(ntiles),xe(ntiles),yb(ntiles),ye(ntiles),pe(ntiles)) call mpp_get_compute_domains(ocean_public%domain, xbegin=xb, xend=xe, ybegin=yb, yend=ye) call mpp_get_pelist(ocean_public%domain, pe) - if (debug > 0) then + if (dbug > 1) then do n = 1,ntiles write(tmpstr,'(a,6i6)') subname//' tiles ',n,pe(n),xb(n),xe(n),yb(n),ye(n) call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO) @@ -1431,6 +1445,11 @@ subroutine ModelAdvance(gcomp, rc) enddo endif + if (dbug > 0) then + call state_diagnose(importState,subname//':IS ',rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + end if + !--------------- ! Get ocean grid !--------------- @@ -1459,6 +1478,10 @@ subroutine ModelAdvance(gcomp, rc) call mom_export(ocean_public, ocean_grid, ocean_state, exportState, clock, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (dbug > 0) then + call state_diagnose(exportState,subname//':ES ',rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + end if endif !--------------- diff --git a/config_src/nuopc_driver/mom_cap_methods.F90 b/config_src/nuopc_driver/mom_cap_methods.F90 index 8aca45094f..0997fbc635 100644 --- a/config_src/nuopc_driver/mom_cap_methods.F90 +++ b/config_src/nuopc_driver/mom_cap_methods.F90 @@ -5,7 +5,7 @@ module MOM_cap_methods use ESMF, only: ESMF_TimeInterval, ESMF_TimeIntervalGet use ESMF, only: ESMF_State, ESMF_StateGet use ESMF, only: ESMF_Field, ESMF_FieldGet, ESMF_FieldCreate -use ESMF, only: ESMF_GridComp, ESMF_Mesh, ESMF_Grid, ESMF_GridCreate +use ESMF, only: ESMF_GridComp, ESMF_Mesh, ESMF_MeshGet, ESMF_Grid, ESMF_GridCreate use ESMF, only: ESMF_DistGrid, ESMF_DistGridCreate use ESMF, only: ESMF_KIND_R8, ESMF_SUCCESS, ESMF_LogFoundError use ESMF, only: ESMF_LOGERR_PASSTHRU, ESMF_LOGMSG_INFO, ESMF_LOGWRITE @@ -13,7 +13,8 @@ module MOM_cap_methods use ESMF, only: ESMF_StateItem_Flag, ESMF_STATEITEM_NOTFOUND use ESMF, only: ESMF_GEOMTYPE_FLAG, ESMF_GEOMTYPE_GRID, ESMF_GEOMTYPE_MESH use ESMF, only: ESMF_RC_VAL_OUTOFRANGE, ESMF_INDEX_DELOCAL, ESMF_MESHLOC_ELEMENT -use ESMF, only: ESMF_TYPEKIND_R8 +use ESMF, only: ESMF_TYPEKIND_R8, ESMF_FIELDSTATUS_COMPLETE +use ESMF, only: ESMF_FieldStatus_Flag, ESMF_LOGMSG_ERROR, ESMF_FAILURE, ESMF_MAXSTR use ESMF, only: operator(/=), operator(==) use MOM_ocean_model_nuopc, only: ocean_public_type, ocean_state_type use MOM_surface_forcing_nuopc, only: ice_ocean_boundary_type @@ -28,6 +29,7 @@ module MOM_cap_methods public :: mom_set_geomtype public :: mom_import public :: mom_export +public :: state_diagnose private :: State_getImport private :: State_setExport @@ -763,6 +765,183 @@ subroutine State_SetExport(state, fldname, isc, iec, jsc, jec, input, ocean_grid end subroutine State_SetExport +subroutine state_diagnose(State, string, rc) + + ! ---------------------------------------------- + ! Diagnose status of State + ! ---------------------------------------------- + + type(ESMF_State), intent(in) :: state + character(len=*), intent(in) :: string + integer , intent(out) :: rc + + ! local variables + integer :: i,j,n + type(ESMf_Field) :: lfield + integer :: fieldCount, lrank + character(ESMF_MAXSTR) ,pointer :: lfieldnamelist(:) + real(ESMF_KIND_R8), pointer :: dataPtr1d(:) + real(ESMF_KIND_R8), pointer :: dataPtr2d(:,:) + character(len=*),parameter :: subname='(state_diagnose)' + character(len=ESMF_MAXSTR) :: msgString + ! ---------------------------------------------- + + call ESMF_StateGet(state, itemCount=fieldCount, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + allocate(lfieldnamelist(fieldCount)) + + call ESMF_StateGet(state, itemNameList=lfieldnamelist, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + do n = 1, fieldCount + + call ESMF_StateGet(state, itemName=lfieldnamelist(n), field=lfield, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + call field_getfldptr(lfield, fldptr1=dataPtr1d, fldptr2=dataPtr2d, rank=lrank, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + if (lrank == 0) then + ! no local data + elseif (lrank == 1) then + if (size(dataPtr1d) > 0) then + write(msgString,'(A,3g14.7,i8)') trim(string)//': '//trim(lfieldnamelist(n)), & + minval(dataPtr1d), maxval(dataPtr1d), sum(dataPtr1d), size(dataPtr1d) + else + write(msgString,'(A,a)') trim(string)//': '//trim(lfieldnamelist(n))," no data" + endif + elseif (lrank == 2) then + if (size(dataPtr2d) > 0) then + write(msgString,'(A,3g14.7,i8)') trim(string)//': '//trim(lfieldnamelist(n)), & + minval(dataPtr2d), maxval(dataPtr2d), sum(dataPtr2d), size(dataPtr2d) + else + write(msgString,'(A,a)') trim(string)//': '//trim(lfieldnamelist(n))," no data" + endif + else + call ESMF_LogWrite(trim(subname)//": ERROR rank not supported ", ESMF_LOGMSG_ERROR) + rc = ESMF_FAILURE + return + endif + call ESMF_LogWrite(trim(msgString), ESMF_LOGMSG_INFO) + enddo + + deallocate(lfieldnamelist) + +end subroutine state_diagnose + +!=============================================================================== + +subroutine field_getfldptr(field, fldptr1, fldptr2, rank, abort, rc) + + ! ---------------------------------------------- + ! for a field, determine rank and return fldptr1 or fldptr2 + ! abort is true by default and will abort if fldptr is not yet allocated in field + ! rank returns 0, 1, or 2. 0 means fldptr not allocated and abort=false + ! ---------------------------------------------- + + ! input/output variables + type(ESMF_Field) , intent(in) :: field + real(ESMF_KIND_R8), pointer , intent(inout), optional :: fldptr1(:) + real(ESMF_KIND_R8), pointer , intent(inout), optional :: fldptr2(:,:) + integer , intent(out) , optional :: rank + logical , intent(in) , optional :: abort + integer , intent(out) , optional :: rc + + ! local variables + type(ESMF_GeomType_Flag) :: geomtype + type(ESMF_FieldStatus_Flag) :: status + type(ESMF_Mesh) :: lmesh + integer :: lrank, nnodes, nelements + logical :: labort + character(len=*), parameter :: subname='(field_getfldptr)' + ! ---------------------------------------------- + + if (.not.present(rc)) then + call ESMF_LogWrite(trim(subname)//": ERROR rc not present ", & + ESMF_LOGMSG_ERROR, line=__LINE__, file=u_FILE_u) + rc = ESMF_FAILURE + return + endif + + rc = ESMF_SUCCESS + + labort = .true. + if (present(abort)) then + labort = abort + endif + lrank = -99 + + call ESMF_FieldGet(field, status=status, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + if (status /= ESMF_FIELDSTATUS_COMPLETE) then + lrank = 0 + if (labort) then + call ESMF_LogWrite(trim(subname)//": ERROR data not allocated ", ESMF_LOGMSG_INFO, rc=rc) + rc = ESMF_FAILURE + return + else + call ESMF_LogWrite(trim(subname)//": WARNING data not allocated ", ESMF_LOGMSG_INFO, rc=rc) + endif + else + + call ESMF_FieldGet(field, geomtype=geomtype, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + if (geomtype == ESMF_GEOMTYPE_GRID) then + call ESMF_FieldGet(field, rank=lrank, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + elseif (geomtype == ESMF_GEOMTYPE_MESH) then + call ESMF_FieldGet(field, rank=lrank, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + call ESMF_FieldGet(field, mesh=lmesh, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + call ESMF_MeshGet(lmesh, numOwnedNodes=nnodes, numOwnedElements=nelements, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + if (nnodes == 0 .and. nelements == 0) lrank = 0 + else + call ESMF_LogWrite(trim(subname)//": ERROR geomtype not supported ", & + ESMF_LOGMSG_INFO, rc=rc) + rc = ESMF_FAILURE + return + endif ! geomtype + + if (lrank == 0) then + call ESMF_LogWrite(trim(subname)//": no local nodes or elements ", & + ESMF_LOGMSG_INFO) + elseif (lrank == 1) then + if (.not.present(fldptr1)) then + call ESMF_LogWrite(trim(subname)//": ERROR missing rank=1 array ", & + ESMF_LOGMSG_ERROR, line=__LINE__, file=u_FILE_u) + rc = ESMF_FAILURE + return + endif + call ESMF_FieldGet(field, farrayPtr=fldptr1, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + elseif (lrank == 2) then + if (.not.present(fldptr2)) then + call ESMF_LogWrite(trim(subname)//": ERROR missing rank=2 array ", & + ESMF_LOGMSG_ERROR, line=__LINE__, file=u_FILE_u) + rc = ESMF_FAILURE + return + endif + call ESMF_FieldGet(field, farrayPtr=fldptr2, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + else + call ESMF_LogWrite(trim(subname)//": ERROR in rank ", & + ESMF_LOGMSG_ERROR, line=__LINE__, file=u_FILE_u) + rc = ESMF_FAILURE + return + endif + + endif ! status + + if (present(rank)) then + rank = lrank + endif + +end subroutine field_getfldptr + logical function chkerr(rc, line, file) integer, intent(in) :: rc integer, intent(in) :: line From 6331da1029854141e9fe88e6730f48652ee928c9 Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Thu, 13 Aug 2020 09:28:16 -0600 Subject: [PATCH 310/316] Remove (:,:) after 2-d variable declariation --- src/tracer/MOM_lateral_boundary_diffusion.F90 | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/tracer/MOM_lateral_boundary_diffusion.F90 b/src/tracer/MOM_lateral_boundary_diffusion.F90 index dd2e015632..73e4669734 100644 --- a/src/tracer/MOM_lateral_boundary_diffusion.F90 +++ b/src/tracer/MOM_lateral_boundary_diffusion.F90 @@ -314,9 +314,9 @@ real function bulk_average(boundary, nk, deg, h, hBLT, phi, ppoly0_E, ppoly0_coe real, dimension(nk) :: h !< Layer thicknesses [H ~> m or kg m-2] real :: hBLT !< Depth of the boundary layer [H ~> m or kg m-2] real, dimension(nk) :: phi !< Scalar quantity - real, dimension(nk,2) :: ppoly0_E(:,:) !< Edge value of polynomial - real, dimension(nk,deg+1) :: ppoly0_coefs(:,:) !< Coefficients of polynomial - integer :: method !< Remapping scheme to use + real, dimension(nk,2) :: ppoly0_E !< Edge value of polynomial + real, dimension(nk,deg+1) :: ppoly0_coefs!< Coefficients of polynomial + integer :: method !< Remapping scheme to use integer :: k_top !< Index of the first layer within the boundary real :: zeta_top !< Fraction of the layer encompassed by the bottom boundary layer From 287281cf6496ff328e208e69fc01e68cf2713c27 Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Thu, 13 Aug 2020 09:33:06 -0600 Subject: [PATCH 311/316] Remove unnecessary present(num_rest_files) condition --- config_src/nuopc_driver/mom_ocean_model_nuopc.F90 | 9 ++------- 1 file changed, 2 insertions(+), 7 deletions(-) diff --git a/config_src/nuopc_driver/mom_ocean_model_nuopc.F90 b/config_src/nuopc_driver/mom_ocean_model_nuopc.F90 index cbbb2261d0..1ba3484ef9 100644 --- a/config_src/nuopc_driver/mom_ocean_model_nuopc.F90 +++ b/config_src/nuopc_driver/mom_ocean_model_nuopc.F90 @@ -690,13 +690,8 @@ subroutine ocean_model_restart(OS, timestamp, restartname, num_rest_files) "restart files can only be created after the buoyancy forcing is applied.") if (present(restartname)) then - if (present(num_rest_files)) then - call save_restart(OS%dirs%restart_output_dir, OS%Time, OS%grid, & - OS%restart_CSp, GV=OS%GV, filename=restartname, num_rest_files=num_rest_files) - else - call save_restart(OS%dirs%restart_output_dir, OS%Time, OS%grid, & - OS%restart_CSp, GV=OS%GV, filename=restartname) - endif + call save_restart(OS%dirs%restart_output_dir, OS%Time, OS%grid, & + OS%restart_CSp, GV=OS%GV, filename=restartname, num_rest_files=num_rest_files) call forcing_save_restart(OS%forcing_CSp, OS%grid, OS%Time, & OS%dirs%restart_output_dir) ! Is this needed? if (OS%use_ice_shelf) then From ab9386c662dbe096c34b29bd55c184b3fafa20bc Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Thu, 13 Aug 2020 09:41:12 -0600 Subject: [PATCH 312/316] In do-loops, use uppercase K index for variables discretized on interfaces --- .../vertical/MOM_tidal_mixing.F90 | 20 +++++++++---------- 1 file changed, 10 insertions(+), 10 deletions(-) diff --git a/src/parameterizations/vertical/MOM_tidal_mixing.F90 b/src/parameterizations/vertical/MOM_tidal_mixing.F90 index 951170c039..708d6a7f46 100644 --- a/src/parameterizations/vertical/MOM_tidal_mixing.F90 +++ b/src/parameterizations/vertical/MOM_tidal_mixing.F90 @@ -783,8 +783,8 @@ subroutine calculate_CVMix_tidal(h, j, G, GV, US, CS, N2_int, Kd_lay, Kd_int, Kv ! XXX: Temporary de-scaling of N2_int(i,:) into a temporary variable - do k=1,G%ke+1 - N2_int_i(k) = US%s_to_T**2 * N2_int(i,k) + do K=1,G%ke+1 + N2_int_i(K) = US%s_to_T**2 * N2_int(i,K) enddo call CVMix_coeffs_tidal( Mdiff_out = Kv_tidal, & @@ -803,14 +803,14 @@ subroutine calculate_CVMix_tidal(h, j, G, GV, US, CS, N2_int, Kd_lay, Kd_int, Kv Kd_lay(i,j,k) = Kd_lay(i,j,k) + 0.5 * US%m2_s_to_Z2_T * (Kd_tidal(k) + Kd_tidal(k+1)) enddo if (present(Kd_int)) then - do k=1,G%ke+1 - Kd_int(i,j,k) = Kd_int(i,j,k) + (US%m2_s_to_Z2_T * Kd_tidal(k)) + do K=1,G%ke+1 + Kd_int(i,j,K) = Kd_int(i,j,K) + (US%m2_s_to_Z2_T * Kd_tidal(K)) enddo endif ! Update viscosity with the proper unit conversion. if (associated(Kv)) then - do k=1,G%ke+1 - Kv(i,j,k) = Kv(i,j,k) + US%m2_s_to_Z2_T * Kv_tidal(k) ! Rescale from m2 s-1 to Z2 T-1. + do K=1,G%ke+1 + Kv(i,j,K) = Kv(i,j,K) + US%m2_s_to_Z2_T * Kv_tidal(K) ! Rescale from m2 s-1 to Z2 T-1. enddo endif @@ -903,15 +903,15 @@ subroutine calculate_CVMix_tidal(h, j, G, GV, US, CS, N2_int, Kd_lay, Kd_int, Kv Kd_lay(i,j,k) = Kd_lay(i,j,k) + 0.5 * US%m2_s_to_Z2_T * (Kd_tidal(k) + Kd_tidal(k+1)) enddo if (present(Kd_int)) then - do k=1,G%ke+1 - Kd_int(i,j,k) = Kd_int(i,j,k) + (US%m2_s_to_Z2_T * Kd_tidal(k)) + do K=1,G%ke+1 + Kd_int(i,j,K) = Kd_int(i,j,K) + (US%m2_s_to_Z2_T * Kd_tidal(K)) enddo endif ! Update viscosity if (associated(Kv)) then - do k=1,G%ke+1 - Kv(i,j,k) = Kv(i,j,k) + US%m2_s_to_Z2_T * Kv_tidal(k) ! Rescale from m2 s-1 to Z2 T-1. + do K=1,G%ke+1 + Kv(i,j,K) = Kv(i,j,K) + US%m2_s_to_Z2_T * Kv_tidal(K) ! Rescale from m2 s-1 to Z2 T-1. enddo endif From 17936f3fd20dbc6725b9f0992933fc31ea3a5079 Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Mon, 24 Aug 2020 10:01:39 -0600 Subject: [PATCH 313/316] Add modifications suggested by Bob Hallberg * Fix grid metrics * Fix averaging expression to get the kinetic energy at a vorticity point * Fix loop ranges --- .../lateral/MOM_hor_visc.F90 | 21 ++++++++++--------- 1 file changed, 11 insertions(+), 10 deletions(-) diff --git a/src/parameterizations/lateral/MOM_hor_visc.F90 b/src/parameterizations/lateral/MOM_hor_visc.F90 index a60d60bb9d..2edafa0f27 100644 --- a/src/parameterizations/lateral/MOM_hor_visc.F90 +++ b/src/parameterizations/lateral/MOM_hor_visc.F90 @@ -515,7 +515,7 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, enddo ; enddo ! Components for the shearing strain - do J=js-2,Jeq+2 ; do I=is-2,Ieq+2 + do J=Jsq-2,Jeq+2 ; do I=Isq-2,Ieq+2 dvdx(I,J) = CS%DY_dxBu(I,J)*(v(i+1,J,k)*G%IdyCv(i+1,J) - v(i,J,k)*G%IdyCv(i,J)) dudy(I,J) = CS%DX_dyBu(I,J)*(u(I,j+1,k)*G%IdxCu(I,j+1) - u(I,j,k)*G%IdxCu(I,j)) enddo ; enddo @@ -694,11 +694,11 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, ! Vorticity if (CS%no_slip) then - do J=js-2,Jeq+2 ; do I=is-2,Ieq+2 + do J=Jsq-2,Jeq+2 ; do I=Isq-2,Ieq+2 vort_xy(I,J) = (2.0-G%mask2dBu(I,J)) * ( dvdx(I,J) - dudy(I,J) ) enddo ; enddo else - do J=js-2,Jeq+2 ; do I=is-2,Ieq+2 + do J=Jsq-2,Jeq+2 ; do I=Isq-2,Ieq+2 vort_xy(I,J) = G%mask2dBu(I,J) * ( dvdx(I,J) - dudy(I,J) ) enddo ; enddo endif @@ -711,22 +711,23 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, if ((CS%Leith_Kh) .or. (CS%Leith_Ah)) then ! Vorticity gradient - do J=js-2,Jeq+2 ; do i=is-1,Ieq+2 + do J=Jsq-1,Jeq+1 ; do i=Isq-1,Ieq+2 DY_dxBu = G%dyBu(I,J) * G%IdxBu(I,J) vort_xy_dx(i,J) = DY_dxBu * (vort_xy(I,J) * G%IdyCu(I,j) - vort_xy(I-1,J) * G%IdyCu(I-1,j)) enddo ; enddo - do j=js-1,Jeq+2 ; do I=is-2,Ieq+2 + do j=Jsq-1,Jeq+2 ; do I=Isq-1,Ieq+1 DX_dyBu = G%dxBu(I,J) * G%IdyBu(I,J) vort_xy_dy(I,j) = DX_dyBu * (vort_xy(I,J) * G%IdxCv(i,J) - vort_xy(I,J-1) * G%IdxCv(i,J-1)) enddo ; enddo ! Laplacian of vorticity do J=Jsq-1,Jeq+1 ; do I=Isq-1,Ieq+1 - DY_dxCv = G%dyCv(i,J) * G%IdxCv(i,J) - DX_dyCu = G%dyCu(I,j) * G%IdyCu(I,j) - Del2vort_q(I,J) = DY_dxCv * (vort_xy_dx(i+1,J) * G%IdyT(i+1,j) - vort_xy_dx(i,J) * G%IdyT(i,j)) + & - DX_dyCu * (vort_xy_dy(I,j+1) * G%IdyT(i,j+1) - vort_xy_dy(I,j) * G%IdyT(i,j)) + DY_dxBu = G%dyBu(I,J) * G%IdxBu(I,J) + DX_dyBu = G%dxBu(I,J) * G%IdyBu(I,J) + + Del2vort_q(I,J) = DY_dxBu * (vort_xy_dx(i+1,J) * G%IdyCv(i+1,J) - vort_xy_dx(i,J) * G%IdyCv(i,J)) + & + DX_dyBu * (vort_xy_dy(I,j+1) * G%IdyCu(I,j+1) - vort_xy_dy(I,j) * G%IdyCu(I,j)) enddo ; enddo do J=Jsq,Jeq+1 ; do I=Isq,Ieq+1 Del2vort_h(i,j) = 0.25*(Del2vort_q(I,J) + Del2vort_q(I-1,J) + Del2vort_q(I,J-1) + Del2vort_q(I-1,J-1)) @@ -1091,7 +1092,7 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, endif if (CS%Re_Ah > 0.0) then - KE = 0.125*((u(I,j,k)+u(I-1,j,k))**2 + (v(i,J,k)+v(i,J-1,k))**2) + KE = 0.125*((u(I,j,k)+u(I,j+1,k))**2 + (v(i,J,k)+v(i+1,J,k))**2) Ah = sqrt(KE) * CS%Re_Ah_const_xy(i,j) endif From e3bc47a8d99c3c40286470f7855f9755000105b8 Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Wed, 26 Aug 2020 10:08:18 -0600 Subject: [PATCH 314/316] Fix letter case to follow MOM6 convention --- src/parameterizations/lateral/MOM_hor_visc.F90 | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/parameterizations/lateral/MOM_hor_visc.F90 b/src/parameterizations/lateral/MOM_hor_visc.F90 index 2edafa0f27..f35c2fb398 100644 --- a/src/parameterizations/lateral/MOM_hor_visc.F90 +++ b/src/parameterizations/lateral/MOM_hor_visc.F90 @@ -636,7 +636,7 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, elseif (OBC%segment(n)%direction == OBC_DIRECTION_S) then if ((J >= js-1) .and. (J <= je+1)) then do I = max(Isq-1,OBC%segment(n)%HI%isd), min(Ieq+1,OBC%segment(n)%HI%ied) - h_u(I,j) = h_u(i,j+1) + h_u(I,j) = h_u(I,j+1) enddo endif elseif (OBC%segment(n)%direction == OBC_DIRECTION_E) then @@ -1087,8 +1087,8 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, endif ! Smagorinsky_Ah or Leith_Ah if (use_MEKE_Au) then ! *Add* the MEKE contribution - Ah = Ah + 0.25*( (MEKE%Au(I,J) + MEKE%Au(I+1,J+1)) + & - (MEKE%Au(I+1,J) + MEKE%Au(I,J+1)) ) + Ah = Ah + 0.25*( (MEKE%Au(i,j) + MEKE%Au(i+1,j+1)) + & + (MEKE%Au(i+1,j) + MEKE%Au(i,j+1)) ) endif if (CS%Re_Ah > 0.0) then @@ -1194,7 +1194,7 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, CS%dy2h(i+1,j)*str_xx(i+1,j)) + & G%IdxCu(I,j)*(CS%dx2q(I,J-1)*str_xy(I,J-1) - & CS%dx2q(I,J) *str_xy(I,J))) * & - G%IareaCu(I,j)) / (h_u(i,j) + h_neglect) + G%IareaCu(I,j)) / (h_u(I,j) + h_neglect) enddo ; enddo if (apply_OBC) then From 2946903bca2e3eb98fda1e3e6b7bea72a0c1c1e9 Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Wed, 26 Aug 2020 14:43:25 -0600 Subject: [PATCH 315/316] Fix one more letter case to follow MOM6 convention --- src/parameterizations/lateral/MOM_hor_visc.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/parameterizations/lateral/MOM_hor_visc.F90 b/src/parameterizations/lateral/MOM_hor_visc.F90 index f35c2fb398..953cc6d838 100644 --- a/src/parameterizations/lateral/MOM_hor_visc.F90 +++ b/src/parameterizations/lateral/MOM_hor_visc.F90 @@ -1923,7 +1923,7 @@ subroutine hor_visc_init(Time, G, US, param_file, diag, CS, MEKE) endif endif if (CS%Leith_Ah) then - CS%biharm6_const_xy(i,j) = Leith_bi_const * (grid_sp_q3 * grid_sp_q3) + CS%biharm6_const_xy(I,J) = Leith_bi_const * (grid_sp_q3 * grid_sp_q3) endif CS%Ah_bg_xy(I,J) = MAX(Ah, Ah_vel_scale * grid_sp_q2 * sqrt(grid_sp_q2)) if (CS%Re_Ah > 0.0) CS%Re_Ah_const_xy(i,j) = grid_sp_q3 / CS%Re_Ah From eb58a2e23242ec0c23dd645ac4e21eaab2a3d490 Mon Sep 17 00:00:00 2001 From: Denise Worthen Date: Wed, 9 Sep 2020 09:41:54 -0400 Subject: [PATCH 316/316] add ocean lag option, make cap consistent (#33) * use flag to control lag startup * additional log msg cleanup * clarify restart_mode control --- config_src/nuopc_driver/mom_cap.F90 | 175 +++++++++--------- config_src/nuopc_driver/mom_cap_methods.F90 | 8 +- .../nuopc_driver/mom_ocean_model_nuopc.F90 | 5 +- .../mom_surface_forcing_nuopc.F90 | 2 +- src/framework/MOM_restart.F90 | 4 +- 5 files changed, 103 insertions(+), 91 deletions(-) diff --git a/config_src/nuopc_driver/mom_cap.F90 b/config_src/nuopc_driver/mom_cap.F90 index d49f370a47..67bae67f74 100644 --- a/config_src/nuopc_driver/mom_cap.F90 +++ b/config_src/nuopc_driver/mom_cap.F90 @@ -72,7 +72,7 @@ module MOM_cap_mod use ESMF, only: ESMF_ArrayCreate use ESMF, only: ESMF_RC_FILE_OPEN, ESMF_RC_FILE_READ, ESMF_RC_FILE_WRITE use ESMF, only: ESMF_VMBroadcast -use ESMF, only: ESMF_AlarmCreate, ESMF_ClockGetAlarmList, ESMF_AlarmList_Flag +use ESMF, only: ESMF_AlarmCreate, ESMF_ClockGetAlarmList, ESMF_AlarmList_Flag use ESMF, only: ESMF_AlarmGet, ESMF_AlarmIsCreated, ESMF_ALARMLIST_ALL, ESMF_AlarmIsEnabled use ESMF, only: ESMF_STATEITEM_NOTFOUND, ESMF_FieldWrite use ESMF, only: operator(==), operator(/=), operator(+), operator(-) @@ -134,6 +134,7 @@ module MOM_cap_mod integer :: logunit !< stdout logging unit number logical :: profile_memory = .true. logical :: grid_attach_area = .false. +logical :: use_coldstart = .true. character(len=128) :: scalar_field_name = '' integer :: scalar_field_count = 0 integer :: scalar_field_idx_grid_nx = 0 @@ -148,7 +149,7 @@ module MOM_cap_mod logical :: cesm_coupled = .false. type(ESMF_GeomType_Flag) :: geomtype = ESMF_GEOMTYPE_GRID #endif -character(len=8) :: restart_mode = 'cmeps' +character(len=8) :: restart_mode = 'alarms' contains @@ -338,6 +339,14 @@ subroutine InitializeP0(gcomp, importState, exportState, clock, rc) call ESMF_LogWrite('MOM_cap:ScalarFieldIdxGridNY = '//trim(logmsg), ESMF_LOGMSG_INFO) endif + use_coldstart = .true. + call NUOPC_CompAttributeGet(gcomp, name="use_coldstart", value=value, & + isPresent=isPresent, isSet=isSet, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (isPresent .and. isSet) use_coldstart=(trim(value)=="true") + write(logmsg,*) use_coldstart + call ESMF_LogWrite('MOM_cap:use_coldstart = '//trim(logmsg), ESMF_LOGMSG_INFO) + end subroutine !> Called by NUOPC to advertise import and export fields. "Advertise" @@ -389,6 +398,8 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) integer :: iostat integer :: readunit character(len=512) :: restartfile ! Path/Name of restart file + character(len=2048) :: restartfiles ! Path/Name of restart files + ! (same as restartfile if single restart file) character(len=*), parameter :: subname='(MOM_cap:InitializeAdvertise)' character(len=32) :: calendar !-------------------------------- @@ -420,6 +431,7 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) CALL ESMF_TimeIntervalGet(TINT, S=DT_OCEAN, RC=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return + !TODO: next two lines not present in NCAR call fms_init(mpi_comm_mom) call constants_init call field_manager_init @@ -527,24 +539,24 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) call ESMF_LogWrite('MOM_cap:startup = '//trim(runtype), ESMF_LOGMSG_INFO) endif - restartfile = "" + restartfile = ""; restartfiles = "" if (runtype == "initial") then if (cesm_coupled) then - restartfile = "n" + restartfiles = "n" else call get_MOM_input(dirs=dirs) - restartfile = dirs%input_filename(1:1) + restartfiles = dirs%input_filename(1:1) endif - call ESMF_LogWrite('MOM_cap:restartfile = '//trim(restartfile), ESMF_LOGMSG_INFO) + call ESMF_LogWrite('MOM_cap:restartfile = '//trim(restartfiles), ESMF_LOGMSG_INFO) else if (runtype == "continue") then ! hybrid or branch or continuos runs if (cesm_coupled) then call ESMF_LogWrite('MOM_cap: restart requested, using rpointer.ocn', ESMF_LOGMSG_WARNING) call ESMF_GridCompGet(gcomp, vm=vm, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + if (ChkErr(rc,__LINE__,u_FILE_u)) return call ESMF_VMGet(vm, localPet=localPet, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + if (ChkErr(rc,__LINE__,u_FILE_u)) return if (localPet == 0) then ! this hard coded for rpointer.ocn right now @@ -554,17 +566,28 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) line=__LINE__, file=u_FILE_u, rcToReturn=rc) return endif - read(readunit,'(a)', iostat=iostat) restartfile - if (iostat /= 0) then - call ESMF_LogSetError(ESMF_RC_FILE_READ, msg=subname//' ERROR reading rpointer.ocn', & - line=__LINE__, file=u_FILE_u, rcToReturn=rc) - return - endif + do + read(readunit,'(a)', iostat=iostat) restartfile + if (iostat /= 0) then + if (len(trim(restartfiles))>1 .and. iostat<0) then + exit ! done reading restart files list. + else + call ESMF_LogSetError(ESMF_RC_FILE_READ, msg=subname//' ERROR reading rpointer.ocn', & + line=__LINE__, file=u_FILE_u, rcToReturn=rc) + return + endif + endif + ! check if the length of restartfiles variable is sufficient: + if (len(restartfiles)-len(trim(restartfiles)) < len(trim(restartfile))) then + call MOM_error(FATAL, "Restart file name(s) too long.") + endif + restartfiles = trim(restartfiles) // " " // trim(restartfile) + enddo close(readunit) endif ! broadcast attribute set on master task to all tasks - call ESMF_VMBroadcast(vm, restartfile, count=ESMF_MAXSTR-1, rootPet=0, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + call ESMF_VMBroadcast(vm, restartfiles, count=len(restartfiles), rootPet=0, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return else call ESMF_LogWrite('MOM_cap: restart requested, use input.nml', ESMF_LOGMSG_WARNING) endif @@ -572,7 +595,7 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) endif ocean_public%is_ocean_pe = .true. - call ocean_model_init(ocean_public, ocean_state, time0, time_start, input_restart_file=trim(restartfile)) + call ocean_model_init(ocean_public, ocean_state, time0, time_start, input_restart_file=trim(restartfiles)) call ocean_model_init_sfc(ocean_state, ocean_public) @@ -1250,9 +1273,9 @@ subroutine DataInitialize(gcomp, rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return call ESMF_ClockGet(clock, currTime=currTime, timeStep=timeStep, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + if (ChkErr(rc,__LINE__,u_FILE_u)) return call ESMF_TimeGet(currTime, timestring=timestr, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + if (ChkErr(rc,__LINE__,u_FILE_u)) return call ESMF_GridCompGetInternalState(gcomp, ocean_internalstate, rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return @@ -1349,10 +1372,12 @@ subroutine ModelAdvance(gcomp, rc) integer :: writeunit integer :: localPet type(ESMF_VM) :: vm - integer :: n + integer :: n, i character(240) :: import_timestr, export_timestr character(len=128) :: fldname character(len=*),parameter :: subname='(MOM_cap:ModelAdvance)' + character(len=8) :: suffix + integer :: num_rest_files rc = ESMF_SUCCESS if(profile_memory) call ESMF_VMLogMemInfo("Entering MOM Model_ADVANCE: ") @@ -1390,7 +1415,7 @@ subroutine ModelAdvance(gcomp, rc) ! Apply ocean lag for startup runs: !--------------- - if (cesm_coupled) then + if (cesm_coupled .or. (.not.use_coldstart)) then if (trim(runtype) == "initial") then ! Do not call MOM6 timestepping routine if the first cpl tstep of a startup run @@ -1489,55 +1514,42 @@ subroutine ModelAdvance(gcomp, rc) !--------------- call ESMF_ClockGetAlarm(clock, alarmname='stop_alarm', alarm=stop_alarm, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ChkErr(rc,__LINE__,u_FILE_u)) return !--------------- ! If restart alarm exists and is ringing - write restart file !--------------- - if (restart_mode == 'cmeps') then + if (restart_mode == 'alarms') then call ESMF_ClockGetAlarm(clock, alarmname='restart_alarm', alarm=restart_alarm, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ChkErr(rc,__LINE__,u_FILE_u)) return if (ESMF_AlarmIsRinging(restart_alarm, rc=rc)) then - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ChkErr(rc,__LINE__,u_FILE_u)) return ! turn off the alarm call ESMF_AlarmRingerOff(restart_alarm, rc=rc ) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ChkErr(rc,__LINE__,u_FILE_u)) return + ! determine restart filename call ESMF_ClockGetNextTime(clock, MyTime, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ChkErr(rc,__LINE__,u_FILE_u)) return call ESMF_TimeGet (MyTime, yy=year, mm=month, dd=day, h=hour, m=minute, s=seconds, rc=rc ) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (cesm_coupled) then call NUOPC_CompAttributeGet(gcomp, name='case_name', value=casename, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + if (ChkErr(rc,__LINE__,u_FILE_u)) return call ESMF_GridCompGet(gcomp, vm=vm, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + if (ChkErr(rc,__LINE__,u_FILE_u)) return call ESMF_VMGet(vm, localPet=localPet, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + if (ChkErr(rc,__LINE__,u_FILE_u)) return write(restartname,'(A,".mom6.r.",I4.4,"-",I2.2,"-",I2.2,"-",I5.5)') & trim(casename), year, month, day, seconds + call ESMF_LogWrite("MOM_cap: Writing restart : "//trim(restartname), ESMF_LOGMSG_INFO) + ! write restart file(s) + call ocean_model_restart(ocean_state, restartname=restartname, num_rest_files=num_rest_files) if (localPet == 0) then ! Write name of restart file in the rpointer file - this is currently hard-coded for the ocean open(newunit=writeunit, file='rpointer.ocn', form='formatted', status='unknown', iostat=iostat) @@ -1547,9 +1559,20 @@ subroutine ModelAdvance(gcomp, rc) return endif write(writeunit,'(a)') trim(restartname)//'.nc' + if (num_rest_files > 1) then + ! append i.th restart file name to rpointer + do i=1, num_rest_files-1 + if (i < 10) then + write(suffix,'("_",I1)') i + else + write(suffix,'("_",I2)') i + endif + write(writeunit,'(a)') trim(restartname) // trim(suffix) // '.nc' + enddo + endif close(writeunit) endif - else + else ! not cesm_coupled ! write the final restart without a timestamp if (ESMF_AlarmIsRinging(stop_alarm, rc=rc)) then write(restartname,'(A)')"MOM.res" @@ -1557,17 +1580,17 @@ subroutine ModelAdvance(gcomp, rc) write(restartname,'(A,I4.4,"-",I2.2,"-",I2.2,"-",I2.2,"-",I2.2,"-",I2.2)') & "MOM.res.", year, month, day, hour, minute, seconds endif - end if - call ESMF_LogWrite("MOM_cap: Writing restart : "//trim(restartname), ESMF_LOGMSG_INFO) + call ESMF_LogWrite("MOM_cap: Writing restart : "//trim(restartname), ESMF_LOGMSG_INFO) - ! write restart file(s) - call ocean_model_restart(ocean_state, restartname=restartname) + ! write restart file(s) + call ocean_model_restart(ocean_state, restartname=restartname) + endif if (is_root_pe()) then write(logunit,*) subname//' writing restart file ',trim(restartname) endif - endif - end if ! end of restart_mode is cmeps + endif + end if ! restart_mode !--------------- ! Write diagnostics @@ -1694,8 +1717,7 @@ subroutine ModelSetRunClock(gcomp, rc) else call NUOPC_CompAttributeGet(gcomp, name="restart_n", value=cvalue, & isPresent=isPresent, isSet=isSet, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, file=__FILE__)) return + if (ChkErr(rc,__LINE__,u_FILE_u)) return ! If restart_n is set and non-zero, then restart_option must be available from config if (isPresent .and. isSet) then @@ -1704,8 +1726,7 @@ subroutine ModelSetRunClock(gcomp, rc) if(restart_n /= 0)then call NUOPC_CompAttributeGet(gcomp, name="restart_option", value=cvalue, & isPresent=isPresent, isSet=isSet, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, file=__FILE__)) return + if (ChkErr(rc,__LINE__,u_FILE_u)) return if (isPresent .and. isSet) then read(cvalue,*) restart_option call ESMF_LogWrite(subname//" Restart_option = "//restart_option, & @@ -1720,25 +1741,20 @@ subroutine ModelSetRunClock(gcomp, rc) ! not used in nems call NUOPC_CompAttributeGet(gcomp, name="restart_ymd", value=cvalue, & isPresent=isPresent, isSet=isSet, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, file=__FILE__)) return + if (ChkErr(rc,__LINE__,u_FILE_u)) return if (isPresent .and. isSet) then read(cvalue,*) restart_ymd call ESMF_LogWrite(subname//" Restart_ymd = "//trim(cvalue), ESMF_LOGMSG_INFO) endif else - ! restart_n is zero, restart_mode will be nems - restart_mode = 'nems' - call ESMF_LogWrite(subname//" Set restart_mode to nems", ESMF_LOGMSG_INFO) + ! restart_n is zero, restarts will be written at finalize only (no alarm control) + restart_mode = 'no_alarms' + call ESMF_LogWrite(subname//" Restarts will be written at finalize only", ESMF_LOGMSG_INFO) endif - else - ! restart_n is not set, restart_mode will be nems - restart_mode = 'nems' - call ESMF_LogWrite(subname//" Set restart_mode to nems", ESMF_LOGMSG_INFO) endif endif - if (restart_mode == 'cmeps') then + if (restart_mode == 'alarms') then call AlarmInit(mclock, & alarm = restart_alarm, & option = trim(restart_option), & @@ -1746,25 +1762,18 @@ subroutine ModelSetRunClock(gcomp, rc) opt_ymd = restart_ymd, & RefTime = mcurrTime, & alarmname = 'restart_alarm', rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ChkErr(rc,__LINE__,u_FILE_u)) return call ESMF_AlarmSet(restart_alarm, clock=mclock, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__)) & - return ! bail out + if (ChkErr(rc,__LINE__,u_FILE_u)) return call ESMF_LogWrite(subname//" Restart alarm is Created and Set", ESMF_LOGMSG_INFO) end if ! create a 1-shot alarm at the driver stop time stop_alarm = ESMF_AlarmCreate(mclock, ringtime=dstopTime, name = "stop_alarm", rc=rc) call ESMF_LogWrite(subname//" Create Stop alarm", ESMF_LOGMSG_INFO) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, file=__FILE__)) return - + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call ESMF_TimeGet(dstoptime, timestring=timestr, rc=rc) call ESMF_LogWrite("Stop Alarm will ring at : "//trim(timestr), ESMF_LOGMSG_INFO) @@ -1822,8 +1831,8 @@ subroutine ocean_model_finalize(gcomp, rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return Time = esmf2fms_time(currTime) - ! Do not write a restart unless mode is nems - if (restart_mode == 'nems') then + ! Do not write a restart unless mode is no_alarms + if (restart_mode == 'no_alarms') then write_restart = .true. else write_restart = .false. diff --git a/config_src/nuopc_driver/mom_cap_methods.F90 b/config_src/nuopc_driver/mom_cap_methods.F90 index 0997fbc635..1d51c1e6dd 100644 --- a/config_src/nuopc_driver/mom_cap_methods.F90 +++ b/config_src/nuopc_driver/mom_cap_methods.F90 @@ -735,7 +735,7 @@ subroutine State_SetExport(state, fldname, isc, iec, jsc, jec, input, ocean_grid do j = jsc, jec jg = j + ocean_grid%jsc - jsc do i = isc, iec - ig = i + ocean_grid%isc - isc + ig = i + ocean_grid%isc - isc n = n+1 dataPtr1d(n) = input(i,j) * ocean_grid%mask2dT(ig,jg) enddo @@ -877,11 +877,11 @@ subroutine field_getfldptr(field, fldptr1, fldptr2, rank, abort, rc) if (status /= ESMF_FIELDSTATUS_COMPLETE) then lrank = 0 if (labort) then - call ESMF_LogWrite(trim(subname)//": ERROR data not allocated ", ESMF_LOGMSG_INFO, rc=rc) + call ESMF_LogWrite(trim(subname)//": ERROR data not allocated ", ESMF_LOGMSG_INFO) rc = ESMF_FAILURE return else - call ESMF_LogWrite(trim(subname)//": WARNING data not allocated ", ESMF_LOGMSG_INFO, rc=rc) + call ESMF_LogWrite(trim(subname)//": WARNING data not allocated ", ESMF_LOGMSG_INFO) endif else @@ -901,7 +901,7 @@ subroutine field_getfldptr(field, fldptr1, fldptr2, rank, abort, rc) if (nnodes == 0 .and. nelements == 0) lrank = 0 else call ESMF_LogWrite(trim(subname)//": ERROR geomtype not supported ", & - ESMF_LOGMSG_INFO, rc=rc) + ESMF_LOGMSG_INFO) rc = ESMF_FAILURE return endif ! geomtype diff --git a/config_src/nuopc_driver/mom_ocean_model_nuopc.F90 b/config_src/nuopc_driver/mom_ocean_model_nuopc.F90 index 22fc90d0c1..2616d99e75 100644 --- a/config_src/nuopc_driver/mom_ocean_model_nuopc.F90 +++ b/config_src/nuopc_driver/mom_ocean_model_nuopc.F90 @@ -671,7 +671,7 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, & end subroutine update_ocean_model !> This subroutine writes out the ocean model restart file. -subroutine ocean_model_restart(OS, timestamp, restartname) +subroutine ocean_model_restart(OS, timestamp, restartname, num_rest_files) 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 @@ -679,6 +679,7 @@ subroutine ocean_model_restart(OS, timestamp, restartname) character(len=*), optional, intent(in) :: restartname !< Name of restart file to use !! This option distinguishes the cesm interface from the !! non-cesm interface + integer, optional, intent(out) :: num_rest_files !< number of restart files written if (.not.MOM_state_is_synchronized(OS%MOM_CSp)) & call MOM_error(WARNING, "End of MOM_main reached with inconsistent "//& @@ -690,7 +691,7 @@ subroutine ocean_model_restart(OS, timestamp, restartname) if (present(restartname)) then call save_restart(OS%dirs%restart_output_dir, OS%Time, OS%grid, & - OS%restart_CSp, GV=OS%GV, filename=restartname) + OS%restart_CSp, GV=OS%GV, filename=restartname, num_rest_files=num_rest_files) call forcing_save_restart(OS%forcing_CSp, OS%grid, OS%Time, & OS%dirs%restart_output_dir) ! Is this needed? if (OS%use_ice_shelf) then diff --git a/config_src/nuopc_driver/mom_surface_forcing_nuopc.F90 b/config_src/nuopc_driver/mom_surface_forcing_nuopc.F90 index 9f207c4a63..3516ad3803 100644 --- a/config_src/nuopc_driver/mom_surface_forcing_nuopc.F90 +++ b/config_src/nuopc_driver/mom_surface_forcing_nuopc.F90 @@ -191,7 +191,7 @@ module MOM_surface_forcing_nuopc integer :: num_stk_bands !< Number of Stokes drift bands passed through the coupler 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 - !! namedfields used for passive tracer fluxes. + !! 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 diff --git a/src/framework/MOM_restart.F90 b/src/framework/MOM_restart.F90 index c918f3a9ee..ca2e37afb9 100644 --- a/src/framework/MOM_restart.F90 +++ b/src/framework/MOM_restart.F90 @@ -849,7 +849,7 @@ 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) +subroutine save_restart(directory, time, G, CS, time_stamped, filename, GV, num_rest_files) 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 @@ -860,6 +860,7 @@ subroutine save_restart(directory, time, G, CS, time_stamped, filename, GV) !! 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 + integer, optional, intent(out) :: num_rest_files !< number of restart files written ! Local variables type(vardesc) :: vars(CS%max_fields) ! Descriptions of the fields that @@ -1056,6 +1057,7 @@ subroutine save_restart(directory, time, G, CS, time_stamped, filename, GV) num_files = num_files+1 enddo + if (present(num_rest_files)) num_rest_files = num_files end subroutine save_restart !> restore_state reads the model state from previously generated files. All